home *** CD-ROM | disk | FTP | other *** search
Text File | 1991-08-01 | 1.5 MB | 34,679 lines |
Text Truncated. Only the first 1MB is shown below. Download the file for the complete contents.
- SVIM-PGM.DOC
- 000000*-----------------------------------------------------------------
- 000100 THE FOLLOWING SOURCE COBOL PROGRAMS WERE THE MOST
- 000200 BASIC PROGRAMS USED IN THE ROUTINE PROCESSING
- 000300 OF THE SOIL VEGETATION INVENTORY METHOD (SVIM).
- 000400 FILES/PROGRAMS PREFIXED BY ES (ECOLOGICAL SITE) IS
- 000500 SYNONYMOUS WITH THE SV (SVIM) SYSTEM CODE.
- 000600
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES005M.
- 000300* CONVERTS THE "V1D" FORMATS TO THE NEW "V1A" FORMATS.
- 000400*
- 000500 AUTHOR. RON BAKER.
- 000500 DATE-WRITTEN. 01/22/80.
- 000600 DATE-COMPILED.
- 000700 ENVIRONMENT DIVISION.
- 000800 CONFIGURATION SECTION.
- 000900 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001000 OBJECT-COMPUTER. LEVEL-66-ASCII.
- 001100 INPUT-OUTPUT SECTION.
- 001200 FILE-CONTROL.
- 001300 SELECT FIL-D1 ASSIGN TO D1
- 001400 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001500 SELECT FIL-I1 ASSIGN TO I1
- 001600 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001700 SELECT FIL-P1 ASSIGN TO P1
- 001800 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001900 SELECT FIL-W1 ASSIGN TO W1
- 002000 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002100 DATA DIVISION.
- 002200 FILE SECTION.
- 002300 FD FIL-D1
- 002400 CODE-SET IS GBCD
- 002500 LABEL RECORDS ARE STANDARD
- 002600 DATA RECORD IS REC-D1.
- 002700 01 REC-D1 PIC X(156).
- 002800 FD FIL-I1
- 002900 CODE-SET IS GBCD
- 003000 LABEL RECORDS ARE STANDARD
- 003100 DATA RECORD IS REC-I1.
- 003200 01 REC-I1.
- 003300 03 RECD-I1.
- 003400 05 REC-TYP-I1 PIC XX.
- 003500 05 FMT-NUM-I1 PIC 9.
- 003600 05 FMT-CD-I1 PIC X.
- 003700 03 SD-I1.
- 003800 05 ST-I1 PIC XX.
- 003900 05 DS-I1 PIC XX.
- 004000 03 RP-I1.
- 004100 05 RA-I1.
- 004200 07 RA-1-I1 PIC X.
- 004300 07 RA-2-I1 PIC X.
- 004400 05 PLU-I1 PIC XX.
- 004500 03 ALOT-I1 PIC XXXX.
- 004600 03 PAST-I1 PIC XX.
- 004700 03 SWAT-I1.
- 004800 05 SWA-I1.
- 004900 07 SWA-1-I1 PIC X.
- 005000 07 SWA-2-I1 PIC XXX.
- 005100 05 TRN-I1 PIC XX.
- 005200 03 DATA-V-I1 PIC X(216).
- 005300 03 DATA-V11-I1 REDEFINES DATA-V-I1.
- 005400 05 COMP-AREA-V11-I1 PIC X.
- 005500 05 DATE-V11-I1 PIC XXXXXX.
- 005600 05 ACT-V11-I1 PIC X.
- 005700 05 AER-V11-I1 PIC X(16).
- 005800 05 INT-V11-I1 PIC XXX.
- 005900 05 OCC-V11-I1 OCCURS 7 TIMES.
- 006000 07 HITS-V11-I1 PIC XXX.
- 006100 07 PLANTS-V11-I1 PIC X(21).
- 006200 07 RTNG-V11-I1 PIC XX.
- 006300 05 FILLER PIC X(7).
- 006400 03 DATA-V12-I1 REDEFINES DATA-V-I1.
- 006500 05 FILLER PIC X(8).
- 006600 05 LINE-V12-I1 PIC XXXX.
- 006700 05 OCCS-V12-I1 OCCURS 4 TIMES.
- 006800 07 CAN-V12-I1 PIC X(39).
- 006900 05 FILLER PIC X(48).
- 007000 03 DATA-V13-I1 REDEFINES DATA-V-I1.
- 007100 05 FILLER PIC X(8).
- 007200 05 LINE-V13-I1 PIC XXXX.
- 007300 05 OCC-V13-I1 OCCURS 9 TIMES.
- 007400 07 PLANT-V13-I1 PIC X(21).
- 007500 05 FILLER PIC X(15).
- 007600 03 DATA-V21-I1 REDEFINES DATA-V-I1.
- 007700 05 DATE-V21-I1 PIC X(6).
- 007800 05 ACT-V21-I1 PIC X.
- 007900 05 TREE-PLOT-SZ-V21-I1 PIC X.
- 008000 05 GRASS-PLOT-SZ-V21-I1 PIC XXXXX.
- 008100 05 LINE-V21-I1 PIC XXXX.
- 008200 05 LINE-V21-I1-RD REDEFINES LINE-V21-I1 PIC 9999.
- 008300 05 OCC-V21-I1 OCCURS 4 TIMES.
- 008400 07 PLOT-NO-V21-I1.
- 008500 09 PN-V21-P1-I1 PIC X.
- 008600 09 PN-V21-P2-I1 PIC X.
- 008700 07 PLOT-NO-V21-I1-RD REDEFINES PLOT-NO-V21-I1
- 008800 PIC 99.
- 008900 07 PLANT-V21-I1 PIC X(7).
- 009000 07 AVAIL-V21-I1 PIC X.
- 009100 07 PHNO-V21-I1 PIC X.
- 009200 07 UTIL-V21-I1 PIC X.
- 009300 07 HGT-CLS-GRP-V21-I1.
- 009400 09 HGT-CLS-V21-I1 PIC XXXX OCCURS 4 TIMES.
- 009500 07 HCAF-V21-I1.
- 009600 09 HGT-V21-I1 PIC XXXX.
- 009700 09 HGT-V21-I1-RD REDEFINES
- 009800 HGT-V21-I1 PIC 999V9.
- 009900 09 CRWN-V21-I1 PIC XXXX.
- 010000 09 CRWN-V21-I1-RD REDEFINES
- 010100 CRWN-V21-I1 PIC 999V9.
- 010200 09 AGE-V21-I1 PIC X.
- 010300 09 FORM-V21-I1 PIC X.
- 010400 07 CHRZ-V21-I1 PIC XXX.
- 010500 07 NOT-CHRZ-V21-I1 PIC XXX.
- 010600 05 FILLER PIC X(23).
- 010700 FD FIL-P1
- 010800 CODE-SET IS GBCD
- 010900 LABEL RECORDS ARE STANDARD
- 011000 DATA RECORD IS REC-P1.
- 011100 01 REC-P1 PIC X(132).
- 011200 SD FIL-W1
- 011300 DATA RECORD IS REC-W1.
- 011400 01 REC-W1.
- 011500 03 SD-W1 PIC XXXX.
- 011600 03 RA-W1 PIC XX.
- 011700 03 PAPSR-W1.
- 011800 05 PLU-W1 PIC XX.
- 011900 05 ALOT-W1 PIC XXXX.
- 012000 05 PAST-W1 PIC XX.
- 012100 05 SWAT-W1 PIC X(6).
- 012200 05 REC-TYP-W1 PIC XX.
- 012300 05 FMT-NUM-W1 PIC X.
- 012400 05 FMT-CD-W1 PIC X.
- 012500 03 GRP-2-W1.
- 012600 05 PLANT-W1 PIC X(7).
- 012700 05 HGT-W1 PIC X.
- 012800 05 HGT-W1-RD REDEFINES HGT-W1 PIC 9.
- 012900 03 PLOT-W1 PIC XX.
- 013000 03 PLOT-W1-RD REDEFINES PLOT-W1 PIC 99.
- 013100 03 OCC-W1 PIC 999.
- 013200 03 LINE-W1 PIC XXX.
- 013300 03 ACT-W1 PIC X.
- 013400 03 DATA-W1 PIC X(240).
- 013500 03 FILLER PIC XXXXX.
- 013600 WORKING-STORAGE SECTION.
- 013700 77 REC-CNT PIC 9(6) VALUE ZEROS.
- 013800 77 REC-TYP-W1-HLD PIC XX VALUE SPACE.
- 013900 77 WR-SW PIC 9 VALUE ZERO.
- 014000 77 END-SW PIC 9 VALUE ZERO.
- 014100 77 PLOT-TOT-HLD PIC 99 VALUE ZERO.
- 014200 77 PLOT-NO-HLD PIC 99 VALUE ZERO.
- 014300 77 LINE-V21-HLD PIC 9999 VALUE ZERO.
- 014400 77 C99I PIC 9(6) VALUE ZERO.
- 014500 77 C11I PIC 9(6) VALUE ZERO.
- 014600 77 C12I PIC 9(6) VALUE ZERO.
- 014700 77 C13I PIC 9(6) VALUE ZERO.
- 014800 77 C21I PIC 9(6) VALUE ZERO.
- 014900 77 C11O PIC 9(6) VALUE ZERO.
- 015000 77 C12O PIC 9(6) VALUE ZERO.
- 015100 77 C13O PIC 9(6) VALUE ZERO.
- 015200 77 C14O PIC 9(6) VALUE ZERO.
- 015300 77 C21O PIC 9(6) VALUE ZERO.
- 015400 77 C31O PIC 9(6) VALUE ZERO.
- 015500 77 C99O PIC 9(6) VALUE ZERO.
- 015600 77 SS PIC 9(6) VALUE ZERO.
- 015700 77 LINE-CNT PIC 9(3) VALUE ZEROS.
- 015800 77 GRP-1-V31-HLD PIC X(20) VALUE SPACE.
- 015900 77 GRP-2-V31-HLD PIC X(8) VALUE SPACE.
- 016000 77 WGT-HLD PIC XXXX VALUE SPACE.
- 016100 77 PLOT-HLD PIC XX VALUE SPACE.
- 016200 77 PAPSR-HLD PIC X(18) VALUE SPACE.
- 016300 77 SUB PIC 9(3) VALUE ZEROS.
- 016400 77 CON-8 VALUE 008 PIC 999.
- 016500 77 SUB1 PIC 9(6) VALUE ZEROS.
- 016600 77 SUB9 PIC 9 VALUE ZEROS.
- 016700 77 PREV-CNTL PIC X(20) VALUE SPACE.
- 016800 01 PLOT-NUM-HOLD.
- 016900 03 PNH PIC XX.
- 017000 03 PNH-RD REDEFINES PNH PIC 99.
- 017100 01 PLOT-TABLE.
- 017200 03 PLOT-TAB PIC 9 OCCURS 40 TIMES.
- 017300 01 REC-W1-HLD PIC X(286) VALUE SPACE.
- 017400 01 V-HLD.
- 017500 03 V-CNTL.
- 017600 05 BATCH-HLD PIC XXXX.
- 017700 05 REC-TYP-HLD PIC XX.
- 017800 05 FMT-NUM-HLD PIC X.
- 017900 05 FMT-CD-HLD PIC X.
- 018000 05 SD-HLD PIC XXXX.
- 018100 05 PLU-HLD PIC XX.
- 018200 05 ALOT-HLD PIC XXXX.
- 018300 05 SWAT-HLD PIC X(6).
- 018400 03 DATA-HLD PIC X(128).
- 018500 03 RA-HLD PIC XX.
- 018600 03 PAST-HLD PIC XX.
- 018700 01 V11.
- 018800 03 V11-CNTL.
- 018900 05 BATCH-V11 PIC XXXX.
- 019000 05 REC-TYP-V11 PIC XX.
- 019100 05 FMT-NUM-V11 PIC X.
- 019200 05 FMT-CD-V11 PIC X.
- 019300 05 SD-V11 PIC XXXX.
- 019400 05 PLU-V11 PIC XX.
- 019500 05 ALOT-V11 PIC XXXX.
- 019600 05 SWAT-V11 PIC X(6).
- 019700 03 DATA-V11.
- 019800 05 ACT-V11 PIC X.
- 019900 05 LINE-V11 PIC XXX.
- 020000 05 EDIT-FLG-V11 PIC X.
- 020100 05 SWAT-BRWD-V11 PIC X(6).
- 020200 05 FILLER PIC X(28).
- 020300 05 DATE-V11 PIC X(6).
- 020400 05 INT-V11 PIC XXX.
- 020500 05 AER-V11 PIC X(16).
- 020600 05 CMPR-SD-V11 PIC XXXX.
- 020700 05 CMPR-FILLER PIC X(12).
- 020800 05 FILLER PIC X(48).
- 020900 05 RA-V11 PIC XX.
- 021000 05 PAST-V11 PIC XX.
- 021100 01 V12.
- 021200 03 V12-CNTL.
- 021300 05 BATCH-V12 PIC XXXX.
- 021400 05 REC-TYP-V12 PIC XX.
- 021500 05 FMT-NUM-V12 PIC X.
- 021600 05 FMT-CD-V12 PIC X.
- 021700 05 SD-V12 PIC XXXX.
- 021800 05 PLU-V12 PIC XX.
- 021900 05 ALOT-V12 PIC XXXX.
- 022000 05 SWAT-V12 PIC X(6).
- 022100 03 DATA-V12.
- 022200 05 ACT-V12 PIC X.
- 022300 05 LINE-V12 PIC 999.
- 022400 05 FILLER PIC X(16).
- 022500 05 THP-V12.
- 022600 07 TYP-GC-V12 PIC X.
- 022700 07 HITS-GC-V12 PIC XXX.
- 022800 07 PLANT-V12 PIC X(21).
- 022900 05 FILLER PIC X(7).
- 023000 05 FILLER PIC X(76).
- 023100 05 RA-V12 PIC XX.
- 023200 05 PAST-V12 PIC XX.
- 023300 01 V13.
- 023400 03 V13-CNTL.
- 023500 05 BATCH-V13 PIC XXXX.
- 023600 05 REC-TYP-V13 PIC XX.
- 023700 05 FMT-NUM-V13 PIC X.
- 023800 05 FMT-CD-V13 PIC X.
- 023900 05 SD-V13 PIC XXXX.
- 024000 05 PLU-V13 PIC XX.
- 024100 05 ALOT-V13 PIC XXXX.
- 024200 05 SWAT-V13 PIC X(6).
- 024300 03 DATA-V13.
- 024400 05 ACT-V13 PIC X.
- 024500 05 LINE-V13 PIC XXX.
- 024600 05 FILLER PIC X(16).
- 024700 05 PLANT-OCC-V13.
- 024800 07 CAN-V13 PIC X(39) OCCURS 2 TIMES.
- 024900 05 FILLER PIC X(30).
- 025000 05 RA-V13 PIC XX.
- 025100 05 PAST-V13 PIC XX.
- 025200 01 V14.
- 025300 03 V14-CNTL.
- 025400 05 BATCH-V14 PIC XXXX.
- 025500 05 REC-TYP-V14 PIC XX.
- 025600 05 FMT-NUM-V14 PIC X.
- 025700 05 FMT-CD-V14 PIC X.
- 025800 05 SD-V14 PIC XXXX.
- 025900 05 PLU-V14 PIC XX.
- 026000 05 ALOT-V14 PIC XXXX.
- 026100 05 SWAT-V14 PIC X(6).
- 026200 03 DATA-V14.
- 026300 05 ACT-V14 PIC X.
- 026400 05 LINE-V14 PIC 999.
- 026500 05 FILLER PIC X(16).
- 026600 05 SSF-V14 OCCURS 7 TIMES PIC XX.
- 026700 05 FILLER PIC X(94).
- 026800 05 RA-V14 PIC XX.
- 026900 05 PAST-V14 PIC XX.
- 027000 01 V21.
- 027100 03 V21-CNTL.
- 027200 05 BATCH-V21 PIC XXXX.
- 027300 05 REC-TYP-V21 PIC XX.
- 027400 05 FMT-NUM-V21 PIC X.
- 027500 05 FMT-CD-V21 PIC X.
- 027600 05 SD-V21 PIC XXXX.
- 027700 05 PLU-V21 PIC XX.
- 027800 05 ALOT-V21 PIC XXXX.
- 027900 05 SWAT-V21 PIC X(6).
- 028000 03 DATA-V21.
- 028100 05 ACT-V21 PIC X.
- 028200 05 LINE-V21 PIC 999.
- 028300 05 FILLER PIC X(16).
- 028400 05 PLOT-SZ-V21 PIC X.
- 028500 05 PLOT-NUM-V21 PIC XX.
- 028600 05 PLANT-V21.
- 028700 07 P1P-V21 PIC X.
- 028800 07 P2P-V21 PIC X.
- 028900 07 P3P-V21 PIC X.
- 029000 07 P4P-V21 PIC X.
- 029100 07 P5P-V21 PIC X.
- 029200 07 P6P-V21 PIC X.
- 029300 07 P7P-V21 PIC X.
- 029400 05 AGE-V21 PIC X.
- 029500 05 FORM-V21 PIC X.
- 029600 05 PHNO-V21 PIC X.
- 029700 05 AVAIL-V21 PIC X.
- 029800 05 UTIL-V21 PIC X.
- 029900 05 HGT-V21 PIC X(5).
- 030000 05 HGT-V21-RD REDEFINES HGT-V21 PIC 999V99.
- 030100 05 CHRZ-V21 PIC XXX.
- 030200 05 FILLER PIC XXXXX.
- 030300 05 CRWN-V21.
- 030400 07 CRWN-V21-3P PIC XXX.
- 030500 07 CRWN-V21-1P1 PIC X.
- 030600 07 CRWN-V21-1P2 PIC X.
- 030700 05 CRWN-V21-RD REDEFINES CRWN-V21 PIC 999V99.
- 030800 05 NOT-CHRZ-V21 PIC XXX.
- 030900 05 FILLER PIC X(72).
- 031000 05 RA-V21 PIC XX.
- 031100 05 PAST-V21 PIC XX.
- 031200 01 V31.
- 031300 03 V31-CNTL.
- 031400 05 BATCH-V31 PIC XXXX.
- 031500 05 GRP-1-V31.
- 031600 07 REC-TYP-V31 PIC XX.
- 031700 07 FMT-NUM-V31 PIC X.
- 031800 07 FMT-CD-V31 PIC X.
- 031900 07 SD-V31 PIC XXXX.
- 032000 07 PLU-V31 PIC XX.
- 032100 07 ALOT-V31 PIC XXXX.
- 032200 07 SWAT-V31 PIC X(6).
- 032300 03 DATA-V31.
- 032400 05 ACT-V31 PIC X.
- 032500 05 LINE-V31 PIC XXX.
- 032600 05 FILLER PIC X(16).
- 032700 05 PLOT-TOT-V31 PIC XX.
- 032800 05 PLOT-SZ-2P-V31 PIC X(2).
- 032900 05 PLOT-SZ-5P-V31.
- 033000 07 PSZ-3P PIC XXX.
- 033100 07 PSZ-2P PIC XX.
- 033200 05 GRP-2-V31.
- 033300 07 PLANT-V31.
- 033400 09 P1P-V31 PIC X.
- 033500 09 P2P-V31 PIC X.
- 033600 09 P3P-V31 PIC X.
- 033700 09 P4P-V31 PIC X.
- 033800 09 P5P-V31 PIC X.
- 033900 09 P6P-V31 PIC X.
- 034000 09 P7P-V31 PIC X.
- 034100 07 HGT-V31 PIC X.
- 034200 05 PLOT-DATA OCCURS 10 TIMES.
- 034300 07 PLOT-V31 PIC XX.
- 034400 07 AVAIL-V31 PIC X.
- 034500 07 PHNO-V31 PIC X.
- 034600 07 UTIL-V31 PIC X.
- 034700 07 WGT-V31 PIC XXXX.
- 034800 05 FILLER PIC X.
- 034900 05 RA-V31 PIC XX.
- 035000 05 PAST-V31 PIC XX.
- 035100 01 GROUND-CVR-TAB.
- 035200 03 TGC-TAB PIC X(7) VALUE "BPNGCSR".
- 035300 03 TGC REDEFINES TGC-TAB PIC X OCCURS 7 TIMES.
- 035400 PROCEDURE DIVISION.
- 035500 SORT-STATEMENT SECTION.
- 035600 SORT-STATEMENT-PARA.
- 035700 SORT FIL-W1 ON ASCENDING KEY SD-W1,
- 035800 PLU-W1, ALOT-W1, PAST-W1, SWAT-W1,
- 035900 PLANT-W1, HGT-W1, PLOT-W1,
- 036000 REC-TYP-W1, FMT-CD-W1, FMT-NUM-W1,
- 036100 LINE-W1, ACT-W1
- 036200 INPUT PROCEDURE IS INPUT-PROC,
- 036300 OUTPUT PROCEDURE IS OUTPUT-PROC.
- 036400 STOP-RUN.
- 036500 DISPLAY "V11I " C11I.
- 036600 DISPLAY "V12I " C12I.
- 036700 DISPLAY "V13I " C13I.
- 036800 DISPLAY "V21I " C21I.
- 036900 DISPLAY "V11O " C11O.
- 037000 DISPLAY "V12O " C12O.
- 037100 DISPLAY "V13O " C13O.
- 037200 DISPLAY "V14O " C14O.
- 037300 DISPLAY "V21O " C21O.
- 037400 DISPLAY "V31O " C31O.
- 037500 DISPLAY "V99O " C99O.
- 037600 CLOSE FIL-D1, FIL-P1. STOP RUN.
- 037700 INPUT-PROC SECTION.
- 037800 010-HOUSEKEEPING.
- 037900 OPEN INPUT FIL-I1.
- 038000 INITIALIZE PLOT-TABLE.
- 038100 010A-READ.
- 038200 MOVE SPACE TO REC-W1.
- 038300 READ FIL-I1 AT END GO TO 099-CLOSE.
- 038400 IF SWA-1-I1 = "0" MOVE "O" TO SWA-1-I1.
- 038500 IF SWA-I1 = SPACE
- 038600 MOVE "Z999" TO SWA-I1.
- 038700 IF ST-I1 = "OT" MOVE "UT" TO ST-I1.
- 038800* MOVE "8" TO RA-2-I1.
- 038900* IF SD-I1 = "UT08" OR "UT07" OR "UT02"
- 039000 IF ST-I1 = "UT"
- 039100 MOVE "UT08" TO SD-I1
- 039200 MOVE "5807" TO RP-I1.
- 039300 ADD 1 TO C99I.
- 039400* DISPLAY REC-I1.
- 039500 MOVE REC-I1 TO DATA-W1.
- 039600* IF REC-CNT > 200 GO TO 099-CLOSE.
- 039700 MOVE REC-TYP-I1 TO REC-TYP-W1.
- 039800 MOVE FMT-NUM-I1 TO FMT-NUM-W1.
- 039900 MOVE FMT-CD-I1 TO FMT-CD-W1.
- 040000 MOVE SD-I1 TO SD-W1.
- 040100 MOVE RA-I1 TO RA-W1.
- 040200 MOVE PLU-I1 TO PLU-W1.
- 040300 MOVE ALOT-I1 TO ALOT-W1.
- 040400 MOVE PAST-I1 TO PAST-W1.
- 040500 MOVE SWAT-I1 TO SWAT-W1.
- 040600 IF RECD-I1 = "V11D" OR "V12D" OR "V13D" OR "V21D"
- 040700 NEXT SENTENCE ELSE
- 040800 DISPLAY "BAD " REC-I1
- 040900 DISPLAY "COUNT= " C99I
- 041000 GO TO 010A-READ.
- 041100 IF RECD-I1 = "V11D"
- 041200 ADD 1 TO C11I
- 041300 MOVE SPACES TO LINE-W1.
- 041400 IF RECD-I1 = "V12D"
- 041500 ADD 1 TO C12I
- 041600 MOVE LINE-V12-I1 TO LINE-W1.
- 041700 IF RECD-I1 = "V21D"
- 041800 ADD 1 TO C21I
- 041900 MOVE LINE-V21-I1 TO LINE-W1
- 042000 MOVE REC-W1 TO REC-W1-HLD.
- 042100 IF RECD-I1 = "V11D" OR "V12D" OR "V13D" OR "V21D"
- 042200 NEXT SENTENCE ELSE
- 042300 DISPLAY "BAD " REC-I1
- 042400 DISPLAY "COUNT= " C99I
- 042500 GO TO 010A-READ.
- 042600 IF RECD-I1 = "V13D"
- 042700 ADD 1 TO C13I
- 042800 MOVE LINE-V13-I1 TO LINE-W1.
- 042900 RELEASE REC-W1.
- 043000 IF RECD-I1 NOT = "V21D"
- 043100 GO TO 010A-READ.
- 043200 MOVE ZERO TO SUB, SUB9.
- 043300 090-LOOP.
- 043400 ADD 1 TO SUB.
- 043500 IF SUB = 5 GO TO 010A-READ.
- 043600 IF ((PN-V21-P2-I1 (SUB) = SPACE) AND
- 043700 (PN-V21-P1-I1 (SUB) NOT = SPACE))
- 043800 MOVE PN-V21-P1-I1 (SUB) TO PN-V21-P2-I1 (SUB)
- 043900 MOVE ZERO TO PN-V21-P1-I1 (SUB).
- 044000 MOVE PLOT-NO-V21-I1 (SUB) TO PNH.
- 044100 IF (PNH = "00" OR "99") OR
- 044200 ((PNH-RD > 40) AND (PNH-RD < 99))
- 044300 DISPLAY "INV " REC-I1
- 044400 DISPLAY "COUNT= " C99I
- 044500 GO TO 090-LOOP.
- 044600 IF (PNH NOT NUMERIC)
- 044700 AND (PLANT-V21-I1 (SUB) NOT = SPACE)
- 044800 DISPLAY "BAD " REC-I1
- 044900 DISPLAY "COUNT= " C99I
- 045000 GO TO 090-LOOP.
- 045100 IF (PNH NOT NUMERIC)
- 045200 GO TO 090-LOOP.
- 045300 IF HGT-CLS-GRP-V21-I1 (SUB) = SPACE
- 045400 GO TO 090-LOOP.
- 045500 095-LOOP.
- 045600 ADD 1 TO SUB9.
- 045700 IF SUB9 = 5
- 045800 MOVE ZERO TO SUB9
- 045900 GO TO 090-LOOP.
- 046000 IF HGT-CLS-V21-I1 (SUB, SUB9) = SPACE
- 046100 GO TO 095-LOOP.
- 046200 MOVE REC-W1-HLD TO REC-W1.
- 046300 MOVE PLANT-V21-I1 (SUB) TO PLANT-W1.
- 046400 MOVE SUB9 TO HGT-W1.
- 046500 MOVE PLOT-NO-V21-I1 (SUB) TO PLOT-W1.
- 046600 MOVE SPACE TO LINE-W1.
- 046700 MOVE "V3" TO REC-TYP-W1.
- 046800 IF PLOT-W1-RD < 11 MOVE "1" TO FMT-NUM-W1
- 046900 ELSE IF PLOT-W1-RD < 21 MOVE "2" TO FMT-NUM-W1
- 047000 ELSE IF PLOT-W1-RD < 31 MOVE "3" TO FMT-NUM-W1
- 047100 ELSE IF PLOT-W1-RD < 41 MOVE "4" TO FMT-NUM-W1.
- 047200 MOVE SUB TO OCC-W1.
- 047300 RELEASE REC-W1.
- 047400 GO TO 095-LOOP.
- 047500 099-CLOSE.
- 047600 CLOSE FIL-I1.
- 047700 099-EXIT.
- 047800 EXIT.
- 047900 OUTPUT-PROC SECTION.
- 048000 100-OPEN.
- 048100 DISPLAY "OUTPUT PROC".
- 048200 OPEN OUTPUT FIL-D1, FIL-P1.
- 048300 100-RET.
- 048400 RETURN FIL-W1 AT END GO TO 999-END.
- 048500 105-CK-REC.
- 048600 IF END-SW = 1
- 048700 GO TO 999-END.
- 048800* DISPLAY "SR= " REC-W1.
- 048900* DISPLAY "GOD " DATA-W1.
- 049000 ADD 1 TO REC-CNT.
- 049100* IF REC-CNT > 200 GO TO 999-END.
- 049200 IF (REC-TYP-W1 NOT = REC-TYP-W1-HLD) AND
- 049300 (REC-TYP-W1-HLD = "V2")
- 049400 MOVE 008 TO CON-8
- 049500 PERFORM 115-PLOT-TAB THRU 115-EXIT.
- 049600 MOVE DATA-W1 TO REC-I1.
- 049700 MOVE REC-TYP-W1 TO REC-TYP-W1-HLD.
- 049800 IF PLANT-W1 NOT = SPACE GO TO 600-V31.
- 049900 IF END-SW = 1 GO TO 999-END.
- 050000 IF RECD-I1 = "V11D" GO TO 200-V11.
- 050100 IF RECD-I1 = "V12D" GO TO 300-V12.
- 050200 IF RECD-I1 = "V13D" GO TO 400-V13.
- 050300 IF RECD-I1 = "V21D" GO TO 500-V21.
- 050400 GO TO 100-RET.
- 050500 110-LOAD.
- 050600 MOVE ZEROES TO BATCH-HLD.
- 050700 MOVE "A" TO FMT-CD-HLD.
- 050800 MOVE SD-I1 TO SD-HLD.
- 050900 MOVE PLU-I1 TO PLU-HLD.
- 051000 MOVE RA-I1 TO RA-HLD.
- 051100 MOVE ALOT-I1 TO ALOT-HLD.
- 051200 MOVE PAST-I1 TO PAST-HLD.
- 051300 MOVE SWAT-I1 TO SWAT-HLD.
- 051400 110-EXIT.
- 051500 EXIT.
- 051600 115-PLOT-TAB.
- 051700 MOVE ZERO TO SUB, PLOT-TOT-HLD.
- 051800 115-LOOP.
- 051900 ADD 1 TO SUB.
- 052000 IF SUB = 41
- 052100 INITIALIZE PLOT-TABLE
- 052200 GO TO 115-EXIT.
- 052300 ADD PLOT-TAB (SUB) TO PLOT-TOT-HLD.
- 052400 GO TO 115-LOOP.
- 052500 115-EXIT.
- 052600 EXIT.
- 052700 200-V11.
- 052800 MOVE SPACE TO V-HLD.
- 052900 PERFORM 110-LOAD.
- 053000 MOVE SPACE TO V11, V12, V14.
- 053100 MOVE V-CNTL TO V11-CNTL V12-CNTL V14-CNTL.
- 053200 MOVE ACT-V11-I1 TO ACT-V11 ACT-V12 ACT-V14.
- 053300 MOVE "V1" TO REC-TYP-V11.
- 053400 MOVE "1" TO FMT-NUM-V11.
- 053500 MOVE "000" TO LINE-V11.
- 053600 MOVE RA-HLD TO RA-V11.
- 053700 MOVE PAST-I1 TO PAST-V11.
- 053800 MOVE AER-V11-I1 TO AER-V11.
- 053900 MOVE INT-V11-I1 TO INT-V11.
- 054000 IF COMP-AREA-V11-I1 = "C"
- 054100 MOVE SD-I1 TO CMPR-SD-V11.
- 054200 MOVE ACT-V11-I1 TO ACT-V11.
- 054300 MOVE DATE-V11-I1 TO DATE-V11.
- 054400* WRITE REC-P1 FROM V11.
- 054500 WRITE REC-D1 FROM V11.
- 054600 ADD 1 TO C11O.
- 054700 ADD 1 TO C99O.
- 054800 MOVE ZERO TO SUB.
- 054900 210-LOOP.
- 055000 ADD 1 TO SUB.
- 055100 IF SUB = 8 GO TO 250-V14.
- 055200 IF HITS-V11-I1 (SUB) > ZERO
- 055300 MOVE TGC (SUB) TO TYP-GC-V12.
- 055400 MOVE SUB TO LINE-V12.
- 055500 MOVE HITS-V11-I1 (SUB) TO HITS-GC-V12.
- 055600 MOVE PLANTS-V11-I1 (SUB) TO PLANT-V12.
- 055700 IF RTNG-V11-I1 (SUB) = SPACE
- 055800 MOVE "99" TO SSF-V14 (SUB)
- 055900 ELSE MOVE RTNG-V11-I1 (SUB) TO SSF-V14 (SUB).
- 056000 IF (PLANT-V12 = SPACE) AND
- 056100 (TYP-GC-V12 = SPACE)
- 056200 GO TO 210-LOOP.
- 056300 MOVE "V1" TO REC-TYP-V12.
- 056400 MOVE "2" TO FMT-NUM-V12.
- 056500 MOVE RA-I1 TO RA-V12.
- 056600 MOVE PAST-I1 TO PAST-V12.
- 056700* WRITE REC-P1 FROM V12.
- 056800 WRITE REC-D1 FROM V12.
- 056900 ADD 1 TO C12O.
- 057000 ADD 1 TO C99O.
- 057100 MOVE SPACE TO THP-V12.
- 057200 GO TO 210-LOOP.
- 057300 250-V14.
- 057400 MOVE 001 TO LINE-V14.
- 057500 MOVE "V1" TO REC-TYP-V14.
- 057600 MOVE "4" TO FMT-NUM-V14.
- 057700 MOVE RA-I1 TO RA-V14.
- 057800 MOVE PAST-I1 TO PAST-V14.
- 057900* WRITE REC-P1 FROM V14.
- 058000 WRITE REC-D1 FROM V14.
- 058100 ADD 1 TO C14O.
- 058200 ADD 1 TO C99O.
- 058300 GO TO 100-RET.
- 058400 300-V12.
- 058500 PERFORM 110-LOAD.
- 058600 MOVE SPACE TO V13.
- 058700 MOVE V-CNTL TO V13-CNTL.
- 058800 MOVE ACT-V11-I1 TO ACT-V13.
- 058900 MOVE "V1" TO REC-TYP-V13.
- 059000 MOVE "3" TO FMT-NUM-V13.
- 059100 MOVE RA-I1 TO RA-V13.
- 059200 MOVE PAST-I1 TO PAST-V13.
- 059300 MOVE ZERO TO SUB SUB1.
- 059400 310-LOOP.
- 059500 ADD 1 TO SUB.
- 059600 IF (SUB = 5) AND (SUB1 = 1)
- 059700* WRITE REC-P1 FROM V13
- 059800 WRITE REC-D1 FROM V13.
- 059900 IF SUB = 5 GO TO 100-RET.
- 060000 IF CAN-V12-I1 (SUB) NOT = SPACE
- 060100 ADD 1 TO SUB1
- 060200 MOVE CAN-V12-I1 (SUB) TO CAN-V13 (SUB1).
- 060300 IF SUB1 = 2
- 060400 ADD 1 TO C13O
- 060500 ADD 1 TO C99O
- 060600* WRITE REC-P1 FROM V13
- 060700 WRITE REC-D1 FROM V13
- 060800 MOVE SPACE TO PLANT-OCC-V13
- 060900 MOVE ZERO TO SUB1.
- 061000 GO TO 310-LOOP.
- 061100 400-V13.
- 061200 PERFORM 110-LOAD.
- 061300 MOVE SPACE TO V12.
- 061400 MOVE V-CNTL TO V12-CNTL
- 061500 MOVE ACT-V11-I1 TO ACT-V12.
- 061600 MOVE "V1" TO REC-TYP-V12.
- 061700 MOVE "2" TO FMT-NUM-V12.
- 061800 MOVE RA-I1 TO RA-V12.
- 061900 MOVE PAST-I1 TO PAST-V12.
- 062000 MOVE ZERO TO SUB.
- 062100 410-LOOP.
- 062200 ADD 1 TO SUB.
- 062300 IF SUB = 10
- 062400 GO TO 100-RET.
- 062500 IF PLANT-V13-I1 (SUB) NOT = SPACE
- 062600 MOVE PLANT-V13-I1 (SUB) TO PLANT-V12
- 062700 ADD 1 TO C12O
- 062800 ADD 1 TO C99O
- 062900* WRITE REC-P1 FROM V12
- 063000 WRITE REC-D1 FROM V12.
- 063100 GO TO 410-LOOP.
- 063200 500-V21.
- 063300 PERFORM 110-LOAD.
- 063400 MOVE SPACE TO V21.
- 063500 MOVE V-CNTL TO V21-CNTL.
- 063600 MOVE "V2" TO REC-TYP-V21.
- 063700 MOVE "1" TO FMT-NUM-V21.
- 063800 MOVE ACT-V21-I1 TO ACT-V21.
- 063900 MOVE RA-I1 TO RA-V21.
- 064000 MOVE PAST-I1 TO PAST-V21.
- 064100 MOVE TREE-PLOT-SZ-V21-I1 TO PLOT-SZ-V21.
- 064200 IF LINE-V21-I1 = SPACE OR ZERO
- 064300 MOVE ZERO TO LINE-V21-HLD
- 064400 ELSE MOVE LINE-V21-I1-RD TO LINE-V21-HLD.
- 064500 MOVE ZERO TO SUB.
- 064600 510-LOOP.
- 064700 ADD 1 TO SUB.
- 064800 IF SUB = 5
- 064900 GO TO 100-RET.
- 065000 IF (PLOT-NO-V21-I1-RD (SUB) > ZERO)
- 065100 AND (PLOT-NO-V21-I1-RD (SUB) < 41)
- 065200 MOVE PLOT-NO-V21-I1-RD (SUB) TO PLOT-NO-HLD
- 065300 MOVE 1 TO PLOT-TAB (PLOT-NO-HLD).
- 065400 IF (HCAF-V21-I1 (SUB) = SPACE) AND
- 065500 (PLANT-V21-I1 (SUB) NOT = "BARREN ")
- 065600 GO TO 510-LOOP.
- 065700 IF (PLANT-V21-I1 (SUB) = "BARREN ") AND
- 065800 (CHRZ-V21-I1 (SUB) > ZERO OR SPACE)
- 065900 GO TO 510-LOOP.
- 066000 MOVE PLOT-NO-V21-I1 (SUB) TO PLOT-NUM-V21.
- 066100 MOVE PLANT-V21-I1 (SUB) TO PLANT-V21.
- 066200 IF P1P-V21 = QUOTE MOVE "+" TO P1P-V21.
- 066300 IF P2P-V21 = QUOTE MOVE "+" TO P2P-V21.
- 066400 IF P3P-V21 = QUOTE MOVE "+" TO P3P-V21.
- 066500 IF P4P-V21 = QUOTE MOVE "+" TO P4P-V21.
- 066600 IF P5P-V21 = QUOTE MOVE "+" TO P5P-V21.
- 066700 IF P6P-V21 = QUOTE MOVE "+" TO P6P-V21.
- 066800 IF P7P-V21 = QUOTE MOVE "+" TO P7P-V21.
- 066900 MOVE AVAIL-V21-I1 (SUB) TO AVAIL-V21.
- 067000 IF AVAIL-V21 = "D" OR "E" MOVE "P" TO AVAIL-V21.
- 067100 IF AVAIL-V21 = "J" MOVE "U" TO AVAIL-V21.
- 067200 IF AVAIL-V21 = "R" MOVE "A" TO AVAIL-V21.
- 067300 IF AVAIL-V21 = "D" OR "E" MOVE "P" TO AVAIL-V21.
- 067400 MOVE PHNO-V21-I1 (SUB) TO PHNO-V21.
- 067500 IF PHNO-V21 = "G" MOVE "6" TO PHNO-V21.
- 067600 MOVE UTIL-V21-I1 (SUB) TO UTIL-V21.
- 067700 IF UTIL-V21 = "O" MOVE "0" TO UTIL-V21.
- 067800 MOVE AGE-V21-I1 (SUB) TO AGE-V21.
- 067900 IF AGE-V21 = "N" MOVE "M" TO AGE-V21.
- 068000 MOVE FORM-V21-I1 (SUB) TO FORM-V21.
- 068100 MOVE CHRZ-V21-I1 (SUB) TO CHRZ-V21.
- 068200 MOVE NOT-CHRZ-V21-I1 (SUB) TO NOT-CHRZ-V21.
- 068300 IF HGT-V21-I1 (SUB) NUMERIC
- 068400 MOVE HGT-V21-I1-RD (SUB) TO HGT-V21-RD
- 068500 ELSE MOVE HGT-V21-I1 (SUB) TO HGT-V21.
- 068600 IF CRWN-V21-I1 (SUB) NUMERIC
- 068700 MOVE CRWN-V21-I1-RD (SUB) TO CRWN-V21-RD
- 068800 ELSE MOVE CRWN-V21-I1 (SUB) TO CRWN-V21.
- 068900 IF (CRWN-V21-1P1 NOT = SPACE) AND
- 069000 (CRWN-V21-3P = SPACE)
- 069100 MOVE ZERO TO CRWN-V21-3P.
- 069200 IF (CRWN-V21-1P1 NOT = SPACE) AND
- 069300 (CRWN-V21-1P2 = SPACE)
- 069400 MOVE ZERO TO CRWN-V21-1P2.
- 069500* IF PREV-CNTL NOT = V21-CNTL
- 069600* MOVE ZERO TO LINE-CNTR.
- 069700* ADD 1 TO LINE-CNTR.
- 069800* MOVE LINE-CNTR TO LINE-V21.
- 069900* MOVE V21-CNTL TO PREV-CNTL.
- 070000* WRITE REC-P1 FROM V21.
- 070100 SUBTRACT 1 FROM SUB.
- 070200 IF LINE-V21-HLD > ZERO
- 070300 ADD SUB LINE-V21-HLD GIVING LINE-V21.
- 070400 ADD 1 TO SUB.
- 070500 WRITE REC-D1 FROM V21.
- 070600 ADD 1 TO C21O.
- 070700 ADD 1 TO C99O.
- 070800 GO TO 510-LOOP.
- 070900 600-V31.
- 071000 IF (SD-W1 = SD-HLD) AND (PAPSR-W1 = PAPSR-HLD)
- 071100 AND (GRP-2-W1 = GRP-2-V31-HLD)
- 071200 GO TO 620-PLOT.
- 071300 IF WR-SW = 1
- 071400 ADD 1 TO LINE-CNT
- 071500* MOVE LINE-CNT TO LINE-V31
- 071600* WRITE REC-P1 FROM V31
- 071700 WRITE REC-D1 FROM V31
- 071800 ADD 1 TO C31O
- 071900 ADD 1 TO C99O
- 072000 MOVE ZERO TO WR-SW.
- 072100 IF (SD-W1 = SD-HLD) AND (PAPSR-W1 = PAPSR-HLD)
- 072200 MOVE ZERO TO LINE-CNT.
- 072300 MOVE ZERO TO SUB.
- 072400 MOVE SPACE TO V31 PLOT-HLD.
- 072500 PERFORM 110-LOAD.
- 072600 MOVE V-CNTL TO V31-CNTL
- 072700 MOVE RA-HLD TO RA-V31.
- 072800 MOVE PAPSR-W1 TO PAPSR-HLD.
- 072900 MOVE PAST-HLD TO PAST-V31.
- 073000 MOVE "V3" TO REC-TYP-V31.
- 073100 MOVE RA-I1 TO RA-V31.
- 073200 MOVE PAST-I1 TO PAST-V31.
- 073300 MOVE FMT-NUM-W1 TO FMT-NUM-V31.
- 073400 IF ST-I1 = "UT" AND ((GRASS-PLOT-SZ-V21-I1 NOT NUMERIC) OR
- 073500 (GRASS-PLOT-SZ-V21-I1 = "00009"))
- 073600 MOVE "00960" TO GRASS-PLOT-SZ-V21-I1.
- 073700 MOVE GRASS-PLOT-SZ-V21-I1 TO PLOT-SZ-5P-V31.
- 073800 IF PLOT-SZ-5P-V31 NOT = SPACE
- 073900 MOVE ZERO TO PLOT-SZ-2P-V31.
- 074000 IF (PSZ-3P = SPACE) AND (PLOT-SZ-2P-V31 = ZERO)
- 074100 MOVE ZERO TO PSZ-3P.
- 074200 MOVE "B" TO FMT-CD-V31.
- 074300 MOVE SPACE TO LINE-V31.
- 074400 MOVE ACT-V21-I1 TO ACT-V31.
- 074500 MOVE HGT-W1 TO HGT-V31.
- 074600 MOVE PLANT-W1 TO PLANT-V31.
- 074700 IF P1P-V31 = QUOTE MOVE "+" TO P1P-V31.
- 074800 IF P2P-V31 = QUOTE MOVE "+" TO P2P-V31.
- 074900 IF P3P-V31 = QUOTE MOVE "+" TO P3P-V31.
- 075000 IF P4P-V31 = QUOTE MOVE "+" TO P4P-V31.
- 075100 IF P5P-V31 = QUOTE MOVE "+" TO P5P-V31.
- 075200 IF P6P-V31 = QUOTE MOVE "+" TO P6P-V31.
- 075300 IF P7P-V31 = QUOTE MOVE "+" TO P7P-V31.
- 075400 MOVE PLOT-TOT-HLD TO PLOT-TOT-V31.
- 075500 MOVE GRP-2-V31 TO GRP-2-V31-HLD.
- 075600 MOVE 1 TO WR-SW.
- 075700 620-PLOT.
- 075800 MOVE HGT-CLS-V21-I1 (OCC-W1, HGT-W1-RD) TO WGT-HLD.
- 075900 IF PLOT-W1 NOT = PLOT-HLD
- 076000 ADD 1 TO SUB.
- 076100 MOVE PLOT-W1 TO PLOT-HLD.
- 076200 IF SUB = 11 MOVE 1 TO SUB.
- 076300 MOVE WGT-HLD TO WGT-V31 (SUB).
- 076400 MOVE PLOT-W1 TO PLOT-V31 (SUB).
- 076500 MOVE AVAIL-V21-I1 (OCC-W1) TO AVAIL-V31 (SUB).
- 076600 MOVE PHNO-V21-I1 (OCC-W1) TO PHNO-V31 (SUB).
- 076700 MOVE UTIL-V21-I1 (OCC-W1) TO UTIL-V31 (SUB).
- 076800 IF PHNO-V31 (SUB) = "G" MOVE "6" TO PHNO-V31 (SUB).
- 076900 IF UTIL-V31 (SUB) = "O" MOVE "0" TO UTIL-V31 (SUB).
- 077000 IF AVAIL-V31 (SUB) = "D" MOVE "P" TO PHNO-V31 (SUB).
- 077100 IF AVAIL-V31 (SUB) = "J" MOVE "U" TO PHNO-V31 (SUB).
- 077200 IF AVAIL-V31 (SUB) = "E" MOVE "P" TO PHNO-V31 (SUB).
- 077300 IF AVAIL-V31 (SUB) = "R" MOVE "A" TO PHNO-V31 (SUB).
- 077400 IF (PHNO-V31 (SUB) NUMERIC) AND
- 077500 (UTIL-V31 (SUB) NOT NUMERIC)
- 077600 MOVE "0" TO UTIL-V31 (SUB).
- 077700 RETURN FIL-W1 AT END
- 077800 MOVE 1 TO END-SW
- 077900 GO TO 625-CK-WR.
- 078000 MOVE DATA-W1 TO REC-I1.
- 078100 IF PLANT-W1 NOT = SPACE
- 078200* DISPLAY "SR= " REC-W1
- 078300* DISPLAY "GOD " DATA-W1
- 078400 ADD 1 TO REC-CNT
- 078500 GO TO 600-V31.
- 078600 625-CK-WR.
- 078700 IF WR-SW = 1 MOVE ZERO TO WR-SW
- 078800 ADD 1 TO LINE-CNT
- 078900* MOVE LINE-CNT TO LINE-V31
- 079000 ADD 1 TO C31O
- 079100 ADD 1 TO C99O
- 079200* WRITE REC-P1 FROM V31
- 079300 WRITE REC-D1 FROM V31.
- 079400 GO TO 105-CK-REC.
- 079500 999-END.
- 079600 DUMMY SECTION.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES010M.
- 000300* CONVERSION OF THE VEGETATIVE RECORDS FROM 144 TO 156 CHAR
- 000400*
- 000500 AUTHOR. CHUCK SLIZEWSKI.
- 000600 DATE-WRITTEN. 01/10/79.
- 000700 DATE-COMPILED.
- 000800 ENVIRONMENT DIVISION.
- 000900 CONFIGURATION SECTION.
- 001000 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001100 OBJECT-COMPUTER. LEVEL-66-ASCII.
- 001200 INPUT-OUTPUT SECTION.
- 001300 FILE-CONTROL.
- 001400 SELECT FIL-D1 ASSIGN TO D1
- 001500 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001600 SELECT FIL-D2 ASSIGN TO D2
- 001700 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001800 SELECT FIL-I1 ASSIGN TO I1
- 001900 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002000 SELECT FIL-W1 ASSIGN TO W1
- 002100 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002200 DATA DIVISION.
- 002300 SUB-SCHEMA SECTION.
- 002400 DB CODVAL2 WITHIN BLMDIC.
- 002500 FILE SECTION.
- 002600 FD FIL-D1
- 002700 CODE-SET IS GBCD
- 002800 LABEL RECORDS ARE STANDARD
- 002900 DATA RECORD IS REC-D1.
- 003000 01 REC-D1 PIC X(144).
- 003100 FD FIL-D2
- 003200 CODE-SET IS GBCD
- 003300 LABEL RECORDS ARE STANDARD
- 003400 DATA RECORD IS REC-D2.
- 003500 01 REC-D2 PIC X(156).
- 003600 FD FIL-I1
- 003700 CODE-SET IS GBCD
- 003800 LABEL RECORDS ARE STANDARD
- 003900 DATA RECORD IS REC-I1.
- 004000 01 REC-I1.
- 004100 03 FILLER PIC XXXX.
- 004200 03 REC-TYP-I1 PIC XXXX.
- 004300 03 ST-I1 PIC XX.
- 004400 03 DS-I1 PIC XX.
- 004500 03 PU-I1 PIC XX.
- 004600 03 FILLER PIC X(138).
- 004700 03 RA-I1 PIC XX.
- 004800 03 PAST-I1 PIC XX.
- 004900 SD FIL-W1
- 005000 DATA RECORD IS REC-W1.
- 005100 01 REC-W1.
- 005200 03 FILLER PIC XXXX.
- 005300 03 REC-TYP-W1 PIC XX.
- 005400 03 FMT-NUM-W1 PIC X.
- 005500 03 FMT-CD-W1 PIC X.
- 005600 03 SDP-A-SWAT-W1.
- 005700 05 SDP-W1.
- 005800 07 ADST-DIST-CDS-W1
- 005900 PIC XXXX.
- 006000 07 PLU-CD-W1 PIC XX.
- 006100 05 FILLER PIC X(10).
- 006200 03 C25-T-61-W1 PIC X(37).
- 006300 03 C62-T-144-W1.
- 006400 05 HRBG-PROD-WGT-3A-W1
- 006500 PIC XXXX OCCURS 10 TIMES.
- 006600 05 FILLER PIC X(43).
- 006700 03 C62-T-144-R1 REDEFINES C62-T-144-W1.
- 006800 05 CLS-PLANT-PROD-WGT-3B-W1
- 006900 PIC X(7) OCCURS 10 TIMES.
- 007000 05 FILLER PIC X(13).
- 007100 03 RA-I-W1 PIC XX.
- 007200 WORKING-STORAGE SECTION.
- 007300 77 REC-DEL-CNTR PIC 9(6) COMP-4 VALUE ZERO.
- 007400 77 FMT-CNT PIC 9(6) VALUE ZERO.
- 007500 77 REC-IN-CNTR PIC 9(6) COMP-4 VALUE ZERO.
- 007600 77 REC-OUT-CNTR PIC 9(6) COMP-4 VALUE ZERO.
- 007700 77 SS2A PIC 99 COMP-4.
- 007800 77 LIN-NUM-H PIC 999.
- 007900 77 RA-CD-H PIC XX.
- 008000 01 PARAMETER.
- 008100 03 RFMAT-FLG PIC XXX.
- 008200 03 FILLER PIC X(77).
- 008300 01 REC-H1.
- 008400 03 C1-T-156-H1.
- 008500 05 C1-T-144-H1.
- 008600 07 FILLER PIC XXXX.
- 008700 07 REC-TYP-H1 PIC XX.
- 008800 07 FMT-NUM-H1 PIC X.
- 008900 07 FMT-CD-H1 PIC X.
- 009000 07 SDP-A-SWAT-H1.
- 009100 09 SDP-H1 PIC X(6).
- 009200 09 ALLOT-H1 PIC X(04).
- 009300 09 FILLER PIC X(06).
- 009400 07 ACTN-CD-LIN-NUM-H1.
- 009500 09 ACTN-CD-H1 PIC X.
- 009600 09 LIN-NUM-H1 PIC 999.
- 009700 07 FILLER PIC X(7).
- 009800 07 RA-CD-H1 PIC XX.
- 009900 07 FILLER PIC X(107).
- 010000 05 FILLER PIC X(8).
- 010100 05 RA-I-H1 PIC XX.
- 010200 05 PS-I-H1 PIC XX.
- 010300 03 C1-T-156-R1 REDEFINES C1-T-156-H1.
- 010400 05 FILLER PIC X(61).
- 010500 05 C62-T-144-H1.
- 010600 07 GRP-3A-H1 PIC X(6) OCCURS 10 TIMES.
- 010700 07 FILLER PIC X(35).
- 010800 05 C62-T-144-R1 REDEFINES C62-T-144-H1.
- 010900 07 GRP-3B-H1 PIC X(9) OCCURS 10 TIMES.
- 011000 07 FILLER PIC X(5).
- 011100 01 HOLD-AREA.
- 011200 03 ADST-CD-T-FMT-NUM-H2.
- 011300 05 SDP-A-SWAT-H2 PIC X(16).
- 011400 05 REC-TYP-H2 PIC XX.
- 011500 05 FMT-CD-H2 PIC X.
- 011600 05 FMT-NUM-H2 PIC X.
- 011700 03 ADST-CD-T-FMT-NUM-H3 PIC X(20) VALUE SPACES.
- 011800 03 GRP-3A-H2.
- 011900 05 PLOT-NUM-3A-H2 PIC 99.
- 012000 05 PLOT-NUM-3A-R2 REDEFINES PLOT-NUM-3A-H2 PIC XX.
- 012100 05 HRBG-PROD-WGT-3A-H2 PIC XXXX.
- 012200 03 GRP-3B-H2.
- 012300 05 PLOT-NUM-3B-H2 PIC 99.
- 012400 05 PLOT-NUM-3B-R2 REDEFINES PLOT-NUM-3B-H2 PIC XX.
- 012500 05 CLS-PLANT-PROD-WGT-3B-H2 PIC X(7).
- 012600 03 ADST-DIST-RA-PLU-CDS-H3.
- 012700 07 ADST-DIST-CDS-H3 PIC XXXX.
- 012800 07 RA-CD-H3.
- 012900 09 RA-CD-C1-H3 PIC 9.
- 013000 09 FILLER PIC 9 VALUE 8.
- 013100 07 PLU-CD-H3 PIC XX.
- 013200 PROCEDURE DIVISION.
- 013300 SS SECTION.
- 013400 SSP.
- 013500 SORT FIL-W1 ON ASCENDING KEY SDP-A-SWAT-W1,
- 013600 REC-TYP-W1,
- 013700 FMT-CD-W1,
- 013800 FMT-NUM-W1,
- 013900 C25-T-61-W1,
- 014000 C62-T-144-W1,
- 014100 INPUT PROCEDURE IS IN-PROC,
- 014200 OUTPUT PROCEDURE IS OT-PROC.
- 014300 IN-PROC SECTION.
- 014400 IPP.
- 014500 ACCEPT PARAMETER.
- 014600 OPEN INPUT FIL-I1,
- 014700 OUTPUT FIL-D2.
- 014800 0100.
- 014900 READ FIL-I1 AT END GO TO 0900.
- 015000 ADD 1 TO FMT-CNT.
- 015100 IF FMT-CNT < 10 DISPLAY "REC-I1= " REC-I1.
- 015200 ADD 1 TO REC-IN-CNTR.
- 015300* MOVE REC-I1 TO REC-H1. MOVE "A" TO ACTN-CD-H1.
- 015400 MOVE REC-I1 TO REC-H1. MOVE "A " TO ACTN-CD-LIN-NUM-H1.
- 015500 IF FMT-CNT < 10 DISPLAY "REC-H1= " REC-H1.
- 015600 MOVE C1-T-144-H1 TO REC-W1.
- 015700 MOVE RA-I-H1 TO RA-I-W1.
- 015800 IF FMT-CNT < 10 DISPLAY "REC-W1= " REC-W1.
- 015900 IF REC-TYP-H1 NOT = "V3" GO TO 0800.
- 016000 IF RFMAT-FLG NOT = "YES" GO TO 0800.
- 016100 MOVE SPACES TO C62-T-144-W1. MOVE 1 TO SS2A.
- 016200 IF FMT-CD-H1 = "B" GO TO 0500.
- 016300 IF FMT-CD-H1 NOT = "A"
- 016400 MOVE REC-I1 TO REC-D2 WRITE REC-D2
- 016500 DISPLAY " BAD FORMAT CODE", DISPLAY REC-I1
- 016600 DISPLAY SPACE GO TO 0100.
- 016700 0200.
- 016800 MOVE GRP-3A-H1 (SS2A) TO GRP-3A-H2.
- 016900 IF GRP-3A-H2 = SPACES GO TO 0400.
- 017000 IF PLOT-NUM-3A-H2 ZERO OR PLOT-NUM-3A-R2 NOT NUMERIC
- 017100 MOVE REC-I1 TO REC-D2 WRITE REC-D2
- 017200 DISPLAY " BAD PLOT NUMBER", DISPLAY REC-I1
- 017300 DISPLAY SPACE GO TO 0100.
- 017400 0300.
- 017500 IF PLOT-NUM-3A-H2 > 10
- 017600 SUBTRACT 10 FROM PLOT-NUM-3A-H2 GO TO 0300.
- 017700 MOVE HRBG-PROD-WGT-3A-H2
- 017800 TO HRBG-PROD-WGT-3A-W1 (PLOT-NUM-3A-H2).
- 017900 0400.
- 018000 IF SS2A < 10 ADD 1 TO SS2A GO TO 0200. GO TO 0800.
- 018100 0500.
- 018200 MOVE GRP-3B-H1 (SS2A) TO GRP-3B-H2.
- 018300 IF GRP-3B-H2 = SPACES GO TO 0700.
- 018400 IF PLOT-NUM-3B-H2 ZERO OR PLOT-NUM-3B-R2 NOT NUMERIC
- 018500 MOVE REC-I1 TO REC-D2 WRITE REC-D2
- 018600 DISPLAY " BAD PLOT NUMBER", DISPLAY REC-I1
- 018700 DISPLAY SPACE GO TO 0100.
- 018800 0600.
- 018900 IF PLOT-NUM-3B-H2 > 10
- 019000 SUBTRACT 10 FROM PLOT-NUM-3B-H2 GO TO 0600.
- 019100 MOVE CLS-PLANT-PROD-WGT-3B-H2
- 019200 TO CLS-PLANT-PROD-WGT-3B-W1 (PLOT-NUM-3B-H2).
- 019300 0700.
- 019400 IF SS2A < 10 ADD 1 TO SS2A GO TO 0500.
- 019500 0800.
- 019600 RELEASE REC-W1. GO TO 0100.
- 019700 0900.
- 019800 CLOSE FIL-I1.
- 019900 OT-PROC SECTION.
- 020000 OPP.
- 020100 OPEN OUTPUT FIL-D1. READY DIC-DE.
- 020200 MOVE ZERO TO FMT-CNT.
- 020300 MOVE SPACES TO SDP-H1.
- 020400 1000-RETURN.
- 020500 RETURN FIL-W1 AT END
- 020600 DISPLAY "TOTAL RECORDS IN = ", REC-IN-CNTR
- 020700 DISPLAY "TOTAL RECORDS DELETED = ", REC-DEL-CNTR
- 020800 DISPLAY "TOTAL RECORDS OUT = ", REC-OUT-CNTR
- 020900 CLOSE FIL-D1, FIL-D2 FINISH DIC-DE STOP RUN.
- 021000 ADD 1 TO FMT-CNT.
- 021100 IF FMT-CNT < 10 DISPLAY "REC-W1= " REC-W1.
- 021200 IF C1-T-144-H1 = REC-W1 DISPLAY SPACE
- 021300 DISPLAY C1-T-144-H1 DISPLAY REC-W1
- 021400 ADD 1 TO REC-DEL-CNTR GO TO 1000-RETURN.
- 021500 IF SDP-H1 = SDP-W1
- 021600 GO TO 1200-WRITE.
- 021700 MOVE ADST-DIST-CDS-W1 TO ADST-DIST-CDS-H3.
- 021800 MOVE RA-I-W1 TO RA-CD-H.
- 021900 MOVE 4 TO RA-CD-C1-H3. MOVE PLU-CD-W1 TO PLU-CD-H3.
- 022000 MOVE 0003 TO DE-NO-8801-DEC.
- 022100 GO TO 1200-WRITE.
- 022200 1100-FIND-RA.
- 022300 MOVE ADST-DIST-RA-PLU-CDS-H3 TO DE-CD-8822-DEC.
- 022400 FIND ANY CODE-DEC.
- 022500 IF DB-STATUS = ZERO
- 022600 MOVE RA-CD-H3 TO RA-CD-H GO TO 1200-WRITE.
- 022700 IF RA-CD-C1-H3 < 8 ADD 1 TO RA-CD-C1-H3
- 022800 GO TO 1100-FIND-RA.
- 022900 MOVE REC-W1 TO REC-D2. WRITE REC-D2.
- 023000 DISPLAY " BAD STATE, DISTRICT, PLANNING UNIT CODES".
- 023100 DISPLAY REC-W1. DISPLAY SPACE. GO TO 1000-RETURN.
- 023200 1200-WRITE.
- 023300 IF FMT-CNT < 10 DISPLAY "REC-W1= " REC-I1.
- 023400 MOVE REC-W1 TO C1-T-144-H1.
- 023500 IF FMT-CNT < 10 DISPLAY "REC-H1= " REC-H1.
- 023600 MOVE SDP-A-SWAT-H1 TO SDP-A-SWAT-H2.
- 023700 MOVE REC-TYP-H1 TO REC-TYP-H2.
- 023800 MOVE FMT-CD-H1 TO FMT-CD-H2.
- 023900 MOVE FMT-NUM-H1 TO FMT-NUM-H2.
- 024000 IF ADST-CD-T-FMT-NUM-H2 NOT = ADST-CD-T-FMT-NUM-H3
- 024100 MOVE ADST-CD-T-FMT-NUM-H2 TO ADST-CD-T-FMT-NUM-H3
- 024200 MOVE ZERO TO LIN-NUM-H. ADD 1 TO LIN-NUM-H.
- 024300 MOVE LIN-NUM-H TO LIN-NUM-H1.
- 024400 MOVE RA-CD-H TO RA-CD-H1. MOVE C1-T-144-H1 TO REC-D1.
- 024500 IF FMT-CNT < 10 DISPLAY "HLD-AR= " HOLD-AREA.
- 024600 IF FMT-CNT < 10 DISPLAY "REC-D1= " REC-D1.
- 024700 WRITE REC-D1. ADD 1 TO REC-OUT-CNTR. GO TO 1000-RETURN.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES021P.
- 000300* VEGETATIVE VERIFICATION LISTING
- 000400*
- 000500 AUTHOR. CHUCK SLIZEWSKI.
- 000500 DATE-WRITTEN. 01/10/79.
- 000600 DATE-COMPILED.
- 000700 ENVIRONMENT DIVISION.
- 000800 CONFIGURATION SECTION.
- 000900 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001000 OBJECT-COMPUTER. LEVEL-66-ASCII.
- 001100 INPUT-OUTPUT SECTION.
- 001200 FILE-CONTROL.
- 001300 SELECT FIL-I1 ASSIGN TO I1
- 001400 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001500 SELECT FIL-P1 ASSIGN TO P1
- 001600 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001700 DATA DIVISION.
- 001800 SUB-SCHEMA SECTION.
- 001900 DB CODVAL2 WITHIN BLMDIC.
- 002000 FILE SECTION.
- 002100 FD FIL-I1
- 002200 CODE-SET IS GBCD
- 002300 LABEL RECORDS ARE STANDARD
- 002400 DATA RECORD IS REC-I1.
- 002500 01 REC-I1 PIC X(144).
- 002600 FD FIL-P1
- 002700 CODE-SET IS GBCD
- 002800 LABEL RECORDS ARE STANDARD
- 002900 DATA RECORD IS REC-P1.
- 003000 01 REC-P1 PIC X(132).
- 003100 WORKING-STORAGE SECTION.
- 003200 77 LIN-CHK PIC 99 COMP-4.
- 003300 77 IN-CNTR PIC 9(6) COMP-4 VALUE ZERO.
- 003400 77 LIN-CNTR PIC 99 COMP-4.
- 003500 77 PAG-CNTR PIC 9999 COMP-4 VALUE ZERO.
- 003600 77 RITE-HDR-FLG PIC 9 COMP-4.
- 003700 77 RITE-KEY-FLG PIC 9 COMP-4.
- 003800 77 SS1A PIC 9 COMP-4.
- 003900 77 SS1B PIC 9 COMP-4.
- 004000 77 SS1C PIC 9 COMP-4.
- 004100 77 SS1D PIC 9 COMP-4.
- 004200 77 SS2A PIC 99 COMP-4.
- 004300 01 COL-HDR1A.
- 004400 03 FILLER PIC X(24) VALUE " ST DIST PL".
- 004500 03 FILLER PIC X(24) VALUE "U ALLOT SWA TRN ".
- 004600 03 FILLER PIC X(84) VALUE SPACES.
- 004700 01 COL-HDR1B.
- 004800 03 FILLER PIC X(24) VALUE " 9-10 11-12 13-".
- 004900 03 FILLER PIC X(24) VALUE "14 15-18 19-22 23-24".
- 005000 03 FILLER PIC X(84) VALUE SPACES.
- 005100 01 COL-HDR1C.
- 005200 03 FILLER PIC X(24) VALUE " XX XX XX".
- 005300 03 FILLER PIC X(24) VALUE " XXXX XXXX XX ".
- 005400 03 FILLER PIC X(84) VALUE SPACES.
- 005500 01 COL-HDRA11 PIC X(108) VALUE "O SWA/T RNG SITE CC VEG S
- 005600- "-TYP % SWA DATE RECR A/PHOTO
- 005700- "CMPR: ST DIST TWP RNG NUM ".
- 005800 01 COL-HDRB11 PIC X(108) VALUE "30-35 45-55 56 57-
- 005900- "60 61-63 64-69 70-72 73-88
- 006000- " 89-90 91-92 93-97 98-102 103-104 ".
- 006100 01 COL-HDRC11 PIC X(108) VALUE "XXXXXX XXXXXXXXXXX X XXX
- 006200- "X XXX XXXXXX XXX XXXXXXXXXXXXX
- 006300- "XXX XX XX XXXXX XXXXX XX ".
- 006400 01 COL-HDRA12 PIC X(108) VALUE "GRND CVR BASAL NUM - - - -
- 006500- " -O B S E R V E D S P E C I E S- - - -
- 006600- " - ".
- 006700 01 COL-HDRB12 PIC X(108) VALUE " DATA: 45 46-48 49-55
- 006800- " 56-62 63-69 70-7
- 006900- "6 ".
- 007000 01 COL-HDRC12 PIC X(108) VALUE " X XXX XXXXXXX
- 007100- " XXXXXXX XXXXXXX XXXXX
- 007200- "XX ".
- 007300 01 COL-HDRA13 PIC X(108) VALUE " BASAL CANOPY 1 CANOPY 2
- 007400- " CANOPY 3 NUM BASAL CANOPY 1
- 007500- " CANOPY 2 CANOPY 3 NUM ".
- 007600 01 COL-HDRB13 PIC X(108) VALUE " 45-53 54-62 63-71
- 007700- " 72-80 81-83 84-92 93-101
- 007800- " 102-110 111-119 120-122 ".
- 007900 01 COL-HDRC13 PIC X(108) VALUE "XXXXXXXXX XXXXXXXXX XXXXXXXX
- 008000- "X XXXXXXXXX XXX XXXXXXXXX XXXXXXXX
- 008100- "X XXXXXXXXX XXXXXXXXX XXX ".
- 008200 01 COL-HDRA14 PIC X(108) VALUE "SOIL MVMT SOIL LITR SURF ROC
- 008300- "K PEDESTALL FLOW PTRN RILLS GUL
- 008400- "LIES ".
- 008500 01 COL-HDRB14 PIC X(108) VALUE " 45-46 47-48 49-50
- 008600- " 51-52 53-54 55-56 57
- 008700- "-58 ".
- 008800 01 COL-HDRC14 PIC X(108) VALUE " XX XX XX
- 008900- " XX XX XX X
- 009000- "X ".
- 009100 01 COL-HDRA21 PIC X(108) VALUE "SIZ/PLOT/NUM SPECIES AGE/CL
- 009200- "ASS/FORM PHNO AVAIL UTIL HGT D/CNT
- 009300- " L/LGT CROWN DIA N/CHARZD M/CROPS ".
- 009400 01 COL-HDRB21 PIC X(108) VALUE "45 46-47 48-54 55
- 009500- " 56 57 58 59 60-64 65-67
- 009600- " 68-72 73-77 78-80 81 ".
- 009700 01 COL-HDRC21 PIC X(108) VALUE " X XX XXXXXXX X
- 009800- " X X X X XXX XX XXX
- 009900- " XXX XX XXX XX XXX X ".
- 010000 01 COL-HDRA3A PIC X(108) VALUE " NUM/PLOT/SIZ SPECIES HGT
- 010100- " WGT-EXT 1 2 3 4 5
- 010200- " 6 7 8 9 10 ".
- 010300 01 COL-HDRB3A PIC X(108) VALUE "45-46 47-53 54-60 61
- 010400- " DATA: 62-65 66-69 70-73 74-77 78-
- 010500- "81 82-85 86-89 90-93 94-97 98-101 ".
- 010600 01 COL-HDRC3A PIC X(108) VALUE " XX XXXXX XX XXXXXXX X
- 010700- " XXXX XXXX XXXX XXXX XXX
- 010800- "X XXXX XXXX XXXX XXXX XXXX ".
- 010900 01 COL-HDRA3B PIC X(108) VALUE "NUM/PLOT/SIZ SPECIES HGT WE
- 011000- " 1 2 3 4 5
- 011100- " 6 7 8 9 10 ".
- 011200 01 COL-HDRB3B PIC X(108) VALUE "45-46 47-53 54-60 61 D: 6
- 011300- "2-68 69-75 76-82 83-89 90-96 97
- 011400- "-103 104-110 111-117 118-124 125-131 ".
- 011500 01 COL-HDRC3B PIC X(108) VALUE " XX XXXXX XX XXXXXXX X XX
- 011600- "XXXXX XXXXXXX XXXXXXX XXXXXXX XXXXXXX XX
- 011700- "XXXXX XXXXXXX XXXXXXX XXXXXXX XXXXXXX ".
- 011800 01 COL-HDR2A.
- 011900 03 FILLER PIC X(24) VALUE "REC TYP ACTN LIN NUM ".
- 012000 03 COL-HDR2A1 PIC X(108).
- 012100 01 COL-HDR2B.
- 012200 03 FILLER PIC X(24) VALUE " 5-8 25 26-28 ".
- 012300 03 COL-HDR2B1 PIC X(108).
- 012400 01 COL-HDR2C.
- 012500 03 FILLER PIC X(24) VALUE " XXXX X XXX ".
- 012600 03 COL-HDR2C1 PIC X(108).
- 012700 01 DATA-LIN1A VALUE SPACES.
- 012800 03 FILLER PIC X.
- 012900 03 REC-TYP-T-FMT-CD-DL1A.
- 013000 05 FILLER PIC XX.
- 013100 05 FMT-NUM-DL1A PIC X.
- 013200 05 FILLER PIC X.
- 013300 03 FILLER PIC X(5).
- 013400 03 ACTN-CD-DL1A PIC X.
- 013500 03 FILLER PIC X(6).
- 013600 03 LIN-NUM-DL1A PIC XXX.
- 013700 03 FILLER PIC XXXX.
- 013800 03 DATA-LIN1A11.
- 013900 05 SWA-BRWD-DL1A11 PIC X(6).
- 014000 05 FILLER PIC XX.
- 014100 05 RNG-SITE-ID-DL1A11 PIC X(11).
- 014200 05 FILLER PIC XX.
- 014300 05 RNG-ECOL-COND-CLS-DL1A11 PIC X.
- 014400 05 FILLER PIC X(5).
- 014500 05 VEG-SUB-TYP-DL1A11 PIC XXXX.
- 014600 05 FILLER PIC X(6).
- 014700 05 SWA-PCT-DL1A11 PIC XXX.
- 014800 05 FILLER PIC XXX.
- 014900 05 DATA-DAT-DL1A11 PIC X(6).
- 015000 05 FILLER PIC XXX.
- 015100 05 RECER-INTLS-DL1A11 PIC XXX.
- 015200 05 FILLER PIC XX.
- 015300 05 PHOTO-ID-DL1A11 PIC X(16).
- 015400 05 FILLER PIC XXX.
- 015500 05 ADST-CD-CMPR-DL1A11 PIC XX.
- 015600 05 FILLER PIC XXXX.
- 015700 05 DIST-CD-CMPR-DL1A11 PIC XX.
- 015800 05 FILLER PIC XXX.
- 015900 05 TWP-CMPR-DL1A11 PIC X(5).
- 016000 05 FILLER PIC X.
- 016100 05 RNG-CMPR-DL1A11 PIC X(5).
- 016200 05 FILLER PIC XXXX.
- 016300 05 CONS-NUM-CMPR-DL1A11 PIC XX.
- 016400 05 FILLER PIC XXXX.
- 016500 03 DATA-LIN1A12 REDEFINES DATA-LIN1A11.
- 016600 05 FILLER PIC X(10).
- 016700 05 TYP-GC-CD-DL1A12 PIC X.
- 016800 05 FILLER PIC X(5).
- 016900 05 TYP-GC-HITS-DL1A12 PIC XXX.
- 017000 05 FILLER PIC XXXX.
- 017100 05 GRP-DL1A12 OCCURS 4 TIMES.
- 017200 07 PLANT-CD-DL1A12 PIC X(7).
- 017300 07 FILLER PIC X(7).
- 017400 05 FILLER PIC X(29).
- 017500 03 DATA-LIN1A13 REDEFINES DATA-LIN1A11.
- 017600 05 GRP1-DL1A13 OCCURS 2 TIMES.
- 017700 07 GRP2-DL1A13 OCCURS 4 TIMES.
- 017800 09 PLANT-CD-DL1A13 PIC X(9).
- 017900 09 FILLER PIC XX.
- 018000 07 TYP-GC-HITS-DL1A13 PIC XXX.
- 018100 07 FILLER PIC XXXX.
- 018200 05 FILLER PIC X(6).
- 018300 03 DATA-LIN1A14 REDEFINES DATA-LIN1A11.
- 018400 05 FILLER PIC XXX.
- 018500 05 GRP-DL1A14 OCCURS 7 TIMES.
- 018600 07 SSF-VAL-RAT-DL1A14 PIC XX.
- 018700 07 FILLER PIC X(9).
- 018800 05 FILLER PIC X(28).
- 018900 03 DATA-LIN1A21 REDEFINES DATA-LIN1A11.
- 019000 05 FILLER PIC X.
- 019100 05 PLOT-SIZ-DL1A21 PIC X.
- 019200 05 FILLER PIC X(7).
- 019300 05 PLOT-NUM-DL1A21 PIC XX.
- 019400 05 FILLER PIC XXXX.
- 019500 05 PLANT-CD-DL1A21 PIC X(7).
- 019600 05 FILLER PIC XXX.
- 019700 05 AGE-CLS-PLANT-DL1A21 PIC X.
- 019800 05 FILLER PIC X(9).
- 019900 05 FORM-CLS-PLANT-DL1A21 PIC X.
- 020000 05 FILLER PIC X(5).
- 020100 05 PHNO-STG-DL1A21 PIC X.
- 020200 05 FILLER PIC X(6).
- 020300 05 CLS-PLANT-AVAIL-DL1A21 PIC X.
- 020400 05 FILLER PIC X(5).
- 020500 05 CLS-PLANT-UTIL-DL1A21 PIC X.
- 020600 05 FILLER PIC XXX.
- 020700 05 AVG-HGT-PLANT-INGR-DL1A21 PIC XXX.
- 020800 05 AVG-HGT-PLANT-DEC-DL1A21 PIC X.
- 020900 05 AVG-HGT-PLANT-FRC-DL1A21 PIC XX.
- 021000 05 FILLER PIC XX.
- 021100 05 CHARZD-NUM-DL1A21 PIC XXX.
- 021200 05 FILLER PIC XXX.
- 021300 05 AVG-LDR-LGT-INGR-DL1A21 PIC XXX.
- 021400 05 AVG-LDR-LGT-DEC-DL1A21 PIC X.
- 021500 05 AVG-LDR-LGT-FRC-DL1A21 PIC XX.
- 021600 05 FILLER PIC XXX.
- 021700 05 AVG-CRN-DIA-INGR-DL1A21 PIC XXX.
- 021800 05 AVG-CRN-DIA-DEC-DL1A21 PIC X.
- 021900 05 AVG-CRN-DIA-FRC-DL1A21 PIC XX.
- 022000 05 FILLER PIC X(5).
- 022100 05 CHARZD-NOT-NUM-DL1A21 PIC XXX.
- 022200 05 FILLER PIC X(8).
- 022300 05 MAST-CROPS-CD-DL1A21 PIC X.
- 022400 05 FILLER PIC XXXX.
- 022500 03 DATA-LIN1A3A REDEFINES DATA-LIN1A11.
- 022600 05 FILLER PIC X.
- 022700 05 PLOT-TOT-NUM-DL1A3A PIC XX.
- 022800 05 FILLER PIC XXXX.
- 022900 05 PLOT-SIZ-EST-INGR-DL1A3A PIC X(5).
- 023000 05 PLOT-SIZ-EST-DEC-DL1A3A PIC X.
- 023100 05 PLOT-SIZ-EST-FRC-DL1A3A PIC XX.
- 023200 05 FILLER PIC XX.
- 023300 05 PLANT-CD-DL1A3A PIC X(7).
- 023400 05 FILLER PIC XXX.
- 023500 05 HGT-CLS-CD-DL1A3A PIC X.
- 023600 05 FILLER PIC X(10).
- 023700 05 GRP-DL1A3A OCCURS 10 TIMES.
- 023800 07 FILLER PIC X.
- 023900 07 HRBG-PROD-WGT-DL1A3A PIC XXXX.
- 024000 07 FILLER PIC XX.
- 024100 03 DATA-LIN1A3B REDEFINES DATA-LIN1A11.
- 024200 05 FILLER PIC X.
- 024300 05 PLOT-TOT-NUM-DL1A3B PIC XX.
- 024400 05 FILLER PIC X.
- 024500 05 PLOT-SIZ-EST-INGR-DL1A3B PIC X(5).
- 024600 05 PLOT-SIZ-EST-DEC-DL1A3B PIC X.
- 024700 05 PLOT-SIZ-EST-FRC-DL1A3B PIC XX.
- 024800 05 FILLER PIC X.
- 024900 05 PLANT-CD-DL1A3B PIC X(7).
- 025000 05 FILLER PIC XX.
- 025100 05 HGT-CLS-CD-DL1A3B PIC X.
- 025200 05 FILLER PIC X(5).
- 025300 05 GRP1-DL1A3B OCCURS 10 TIMES.
- 025400 07 GRP2-DL1A3B PIC X(7).
- 025500 07 FILLER PIC X.
- 025600 01 HOLD-AREA.
- 025700 03 ADST-CD-T-TRN-NUM-H PIC X(16) VALUE SPACES.
- 025800 03 ADST-CD-T-TRN-NUM-D11H.
- 025900 05 ADST-CD-D11H PIC XX VALUE SPACES.
- 026000 05 DIST-CD-D11H PIC XX.
- 026100 05 PLU-CD-D11H PIC XX.
- 026200 05 ALLOT-NUM-D11H PIC XXXX.
- 026300 05 SWA-CD-D11H PIC XXXX.
- 026400 05 TRN-NUM-D11H PIC XX.
- 026500 03 ADST-INV-NAM-H.
- 026600 05 ADST-NAM-H PIC X(10).
- 026700 05 INV-NAM-H PIC X(30).
- 026800 03 DAT-H.
- 026900 05 YER-H PIC XX.
- 027000 05 MON-H PIC 99.
- 027100 05 DAY-H PIC XX.
- 027200 01 KEY-LIN1A.
- 027300 03 FILLER PIC X(10) VALUE SPACES.
- 027400 03 ADST-CD-KL1A PIC XX.
- 027500 03 FILLER PIC XXXX VALUE SPACES.
- 027600 03 DIST-CD-KL1A PIC XX.
- 027700 03 FILLER PIC XXXX VALUE SPACES.
- 027800 03 PLU-CD-KL1A PIC XX.
- 027900 03 FILLER PIC XXXX VALUE SPACES.
- 028000 03 ALLOT-NUM-KL1A PIC XXXX.
- 028100 03 FILLER PIC XXXX VALUE SPACES.
- 028200 03 SWA-CD-KL1A PIC XXXX.
- 028300 03 FILLER PIC XXXX VALUE SPACES.
- 028400 03 TRN-NUM-KL1A PIC XX.
- 028500 03 FILLER PIC X(86) VALUE SPACES.
- 028600 01 PAG-HDR1.
- 028700 03 FILLER PIC XXXX VALUE SPACES.
- 028800 03 MON-PH1 PIC XXX.
- 028900 03 FILLER PIC X VALUE SPACE.
- 029000 03 DAY-PH1 PIC XX.
- 029100 03 FILLER PIC XXXX VALUE ", 19".
- 029200 03 YER-PH1 PIC XX.
- 029300 03 FILLER PIC X(26) VALUE SPACES.
- 029400 03 FILLER PIC X(49) VALUE "USDI - BUR OF LAND MGT ECOLOGI
- 029500- "CAL SITE INVENTORY".
- 029600 03 FILLER PIC X(26) VALUE SPACES.
- 029700 03 FILLER PIC X(06) VALUE "PAGE: ".
- 029800 03 PAG-CNT-PH1 PIC ZZ,ZZ9.
- 029900 03 FILLER PIC X(03) VALUE SPACES.
- 030000 01 PAG-HDR2.
- 030100 03 FILLER PIC X(7) VALUE "STATE: ".
- 030200 03 STATE-HDR PIC X(10).
- 030300 03 FILLER PIC X(8) VALUE " INV: ".
- 030400 03 INVEN-CD-HDR PIC XXXX.
- 030500 03 FILLER PIC XXXXX VALUE " - ".
- 030600 03 INVENTORY-HDR PIC X(20).
- 030700 03 FILLER PIC X(4) VALUE SPACES.
- 030800 03 FILLER PIC X(42) VALUE "V1, V2, V3 VERIFICATION LIST -
- 030900- "PCN: ES021P".
- 031000 03 FILLER PIC X(32) VALUE SPACES.
- 031100 01 REC-H1.
- 031200 03 FILLER PIC X(8) VALUE "0000V00A".
- 031300 03 ADST-CD-T-TRN-NUM-H1 PIC X(16).
- 031400 03 FILLER PIC X(120).
- 031500 01 TABL-AREA.
- 031600 03 MON-V PIC X(36) VALUE "JANFEBMARAPRMAYJUNJULAUGSEPOCT
- 031700- "NOVDEC".
- 031800 03 MON-T REDEFINES MON-V PIC XXX OCCURS 12 TIMES.
- 031900 01 D11X.
- 032000 03 BATCH-NUM-D11X PIC XXXX.
- 032100 03 REC-TYP-T-FMT-CD-D11X.
- 032200 05 REC-TYP-D11X PIC XX.
- 032300 05 FMT-NUM-D11X PIC X.
- 032400 05 FMT-CD-D11X PIC X.
- 032500 03 ADST-CD-T-TRN-NUM-D11X.
- 032600 05 ADST-DIST-PLU-CDS-D11X PIC X(6).
- 032700 05 ALLOT-NUM-T-TRN-NUM-D11X PIC X(10).
- 032800 03 ACTN-CD-D11X PIC X.
- 032900 03 LIN-NUM-D11X PIC XXX.
- 033000 03 FILLER PIC X.
- 033100 03 SWA-BRWD-D11X.
- 033200 05 SWA-CD-BRWD-D11X PIC X.
- 033300 05 SWA-NUM-BRWD-D11X PIC XXX.
- 033400 05 TRN-NUM-BRWD-D11X PIC XX.
- 033500 03 FILLER PIC X(9).
- 033600 03 D11AX.
- 033700 05 RNG-SITE-ID-D11AX PIC X(11).
- 033800 05 RNG-ECOL-COND-CLS-D11AX PIC X.
- 033900 05 VEG-SUB-TYP-D11AX PIC XXXX.
- 034000 05 SWA-PCT-D11AX PIC XXX.
- 034100 05 DATA-DAT-D11AX.
- 034200 07 DATA-YER-D11AX PIC XX.
- 034300 07 DATA-MON-D11AX PIC XX.
- 034400 07 DATA-DAY-D11AX PIC XX.
- 034500 05 RECER-INTLS-D11AX PIC XXX.
- 034600 05 PHOTO-ID-D11AX PIC X(16).
- 034700 05 CMPR-ID-D11AX.
- 034800 07 ADST-DIST-CDS-CMPR-D11AX.
- 034900 09 ADST-CD-CMPR-D11AX PIC XX.
- 035000 09 DIST-CD-CMPR-D11AX PIC XX.
- 035100 07 TWP-CMPR-D11AX.
- 035200 09 TWP-NUM-CMPR-D11AX PIC XXX.
- 035300 09 TWP-FRC-CMPR-D11AX PIC X.
- 035400 09 TWP-DIR-CMPR-D11AX PIC X.
- 035500 07 RNG-CMPR-D11AX.
- 035600 09 RNG-NUM-CMPR-D11AX PIC XXX.
- 035700 09 RNG-FRC-CMPR-D11AX PIC X.
- 035800 09 RNG-DIR-CMPR-D11AX PIC X.
- 035900 07 CONS-NUM-CMPR-D11AX PIC XX.
- 036000 05 FILLER PIC X(40).
- 036100 03 D12AX REDEFINES D11AX.
- 036200 05 TYP-GC-CD-D12AX PIC X.
- 036300 05 TYP-GC-HITS-D12AX PIC XXX.
- 036400 05 PLANT-CD-D12AX PIC X(7) OCCURS 4 TIMES.
- 036500 05 FILLER PIC X(68).
- 036600 03 D13AX REDEFINES D11AX.
- 036700 05 GRP1-D13AX.
- 036800 07 FILLER PIC X(39).
- 036900 07 PLANT-CDS-TYP-GC-HITS-D13AX PIC X(39).
- 037000 05 GRP2-D13AX REDEFINES GRP1-D13AX OCCURS 2 TIMES.
- 037100 07 PLANT-CD-D13AX PIC X(9) OCCURS 4 TIMES.
- 037200 07 TYP-GC-HITS-D13AX PIC XXX.
- 037300 05 FILLER PIC X(22).
- 037400 03 D14AX REDEFINES D11AX.
- 037500 05 SSF-VAL-RAT-D14AX PIC XX OCCURS 7 TIMES.
- 037600 05 FILLER PIC X(86).
- 037700 03 D21AX REDEFINES D11AX.
- 037800 05 PLOT-SIZ-D21AX PIC X.
- 037900 05 PLOT-NUM-D21AX PIC XX.
- 038000 05 PLANT-CD-D21AX PIC X(7).
- 038100 05 AGE-CLS-PLANT-D21AX PIC X.
- 038200 05 FORM-CLS-PLANT-D21AX PIC X.
- 038300 05 PHNO-STG-D21AX PIC X.
- 038400 05 CLS-PLANT-AVAIL-D21AX PIC X.
- 038500 05 CLS-PLANT-UTIL-D21AX PIC X.
- 038600 05 AVG-HGT-PLANT-D21AX.
- 038700 07 AVG-HGT-PLANT-INGR-D21AX PIC XXX.
- 038800 07 AVG-HGT-PLANT-FRC-D21AX PIC XX.
- 038900 05 CHARZD-NUM-D21AX PIC XXX.
- 039000 05 AVG-LDR-LGT-D21AX.
- 039100 07 AVG-LDR-LGT-INGR-D21AX PIC XXX.
- 039200 07 AVG-LDR-LGT-FRC-D21AX PIC XX.
- 039300 05 AVG-CRN-DIA-D21AX.
- 039400 07 AVG-CRN-DIA-INGR-D21AX PIC XXX.
- 039500 07 AVG-CRN-DIA-FRC-D21AX PIC XX.
- 039600 05 CHARZD-NOT-NUM-D21AX PIC XXX.
- 039700 05 MAST-CROPS-CD-D21AX PIC X.
- 039800 05 FILLER PIC X(63).
- 039900 03 V3XAX REDEFINES D11AX.
- 040000 05 PLOT-TOT-NUM-V3XAX PIC XX.
- 040100 05 PLOT-SIZ-EST-V3XAX.
- 040200 07 PLOT-SIZ-EST-INGR-V3XAX PIC X(5).
- 040300 07 PLOT-SIZ-EST-FRC-V3XAX PIC XX.
- 040400 05 PLANT-CD-V3XAX PIC X(7).
- 040500 05 HGT-CLS-CD-V3XAX PIC X.
- 040600 05 HRBG-PROD-WGT-V3XAX PIC XXXX OCCURS 10 TIMES.
- 040700 05 FILLER PIC X(43).
- 040800 03 V3XBX REDEFINES D11AX.
- 040900 05 PLOT-TOT-NUM-V3XBX PIC XX.
- 041000 05 PLOT-SIZ-EST-V3XBX.
- 041100 07 PLOT-SIZ-EST-INGR-V3XBX PIC X(5).
- 041200 07 PLOT-SIZ-EST-FRC-V3XBX PIC XX.
- 041300 05 PLANT-CD-V3XBX PIC X(7).
- 041400 05 HGT-CLS-CD-V3XBX PIC X.
- 041500 05 GRP-V3XBX OCCURS 10 TIMES.
- 041600 07 CLS-PLANT-AVAIL-V3XBX PIC X.
- 041700 07 PHNO-STG-V3XBX PIC X.
- 041800 07 CLS-PLANT-UTIL-V3XBX PIC X.
- 041900 07 HRBG-PROD-WGT-V3XBX PIC XXXX.
- 042000 05 FILLER PIC X(13).
- 042100 01 DIC-HOLD.
- 042200 03 INV-HLD.
- 042300 05 INV-NM PIC X(20).
- 042400 05 ST-DIST-CD.
- 042500 07 ST-CD-HLD PIC X(02).
- 042600 07 DI-CD-HLD PIC X(02).
- 042700 03 EXPL-HLD.
- 042800 05 DIST-NM-HLD PIC X(12).
- 042900 03 FUNC-HLD.
- 043000 05 ST-NM-HLD PIC X(10).
- 043100 05 FILLER PIC X(14).
- 043200 COPY DBSTATUS IN TPCOBOLIB.
- 043300 01 INVENTORY PIC XXXX VALUE SPACE.
- 043400 PROCEDURE DIVISION.
- 043500 START-PARA.
- 043600 ACCEPT DAT-H FROM DATE. MOVE MON-T (MON-H) TO MON-PH1.
- 043700 MOVE DAY-H TO DAY-PH1. MOVE YER-H TO YER-PH1.
- 043800 OPEN INPUT FIL-I1,
- 043900 OUTPUT FIL-P1.
- 044000 ACCEPT INVENTORY.
- 044100 READY DIC-DE.
- 044200 000-VALIDATE-INV.
- 044300 MOVE INVENTORY TO DE-CD-8822-DEC INVEN-CD-HDR.
- 044400 MOVE 3940 TO DE-NO-8801-DEC.
- 044500 FIND ANY CODE-DEC.
- 044600 MOVE DB-STATUS TO DB-STAT.
- 044700 IF NOT OK
- 044800 MOVE "UNKNOWN" TO STATE-HDR INVENTORY-HDR
- 044900 GO TO 000-EXIT.
- 045000 GET CODE-DEC.
- 045100 MOVE DB-STATUS TO DB-STAT.
- 045200 IF NOT OK
- 045300 MOVE "UNKNOWN" TO STATE-HDR INVENTORY-HDR
- 045400 GO TO 000-EXIT.
- 045500 MOVE DE-CD-NAM-8823-DEC TO INV-HLD.
- 045600 MOVE INV-NM TO INVENTORY-HDR.
- 045700 000-VALIDATE-STDI.
- 045800 MOVE ST-DIST-CD TO DE-CD-8822-DEC.
- 045900 MOVE 0003 TO DE-NO-8801-DEC.
- 046000 FIND ANY CODE-DEC.
- 046100 MOVE DB-STATUS TO DB-STAT.
- 046200 IF NOT OK
- 046300 MOVE "UNKNOWN" TO STATE-HDR
- 046400 GO TO 000-EXIT.
- 046500 GET CODE-DEC.
- 046600 MOVE DB-STATUS TO DB-STAT.
- 046700 IF NOT OK
- 046800 MOVE "UNKNOWN" TO STATE-HDR
- 046900 GO TO 000-EXIT.
- 047000 FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
- 047100 MOVE DB-STATUS TO DB-STAT.
- 047200 IF NOT OK
- 047300 MOVE "UNKNOWN" TO STATE-HDR
- 047400 GO TO 000-EXIT.
- 047500 GET CODE-EXPL-DECE.
- 047600 MOVE DB-STATUS TO DB-STAT.
- 047700 IF NOT OK
- 047800 MOVE "UNKNOWN" TO STATE-HDR
- 047900 GO TO 000-EXIT.
- 048000 MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HLD.
- 048100 MOVE DE-CD-NAM-8823-DEC TO FUNC-HLD.
- 048200 MOVE ST-NM-HLD TO STATE-HDR.
- 048300 000-EXIT.
- 048400 EXIT.
- 048500 000-FINISH.
- 048600 FINISH DIC-DE.
- 048700 0400.
- 048800 READ FIL-I1 AT END
- 048900 DISPLAY "RECORDS IN = ", IN-CNTR
- 049000 CLOSE FIL-I1, FIL-P1 STOP RUN.
- 049100 MOVE REC-I1 TO D11X. ADD 1 TO IN-CNTR.
- 049200 IF ADST-CD-T-TRN-NUM-D11H NOT = ADST-CD-T-TRN-NUM-D11X
- 049300 MOVE ADST-CD-T-TRN-NUM-D11X TO ADST-CD-T-TRN-NUM-D11H
- 049400 MOVE 1 TO RITE-HDR-FLG, RITE-KEY-FLG MOVE 52 TO LIN-CHK
- 049500 MOVE ADST-CD-D11H TO ADST-CD-KL1A
- 049600 MOVE DIST-CD-D11H TO DIST-CD-KL1A
- 049700 MOVE PLU-CD-D11H TO PLU-CD-KL1A
- 049800 MOVE ALLOT-NUM-D11H TO ALLOT-NUM-KL1A
- 049900 MOVE SWA-CD-D11H TO SWA-CD-KL1A
- 050000 MOVE TRN-NUM-D11H TO TRN-NUM-KL1A.
- 050100 IF REC-TYP-D11X = "V2" GO TO 0900.
- 050200 IF REC-TYP-D11X = "V3" MOVE 1 TO SS2A GO TO 1000.
- 050300 IF REC-TYP-D11X NOT = "V1"
- 050400 DISPLAY REC-TYP-T-FMT-CD-D11X
- 050500 DISPLAY "BAD RECORD TYPE" CALL "ABOR".
- 050600 IF FMT-NUM-D11X = "2" MOVE 1 TO SS1A GO TO 0600.
- 050700 IF FMT-NUM-D11X = "3" MOVE 1 TO SS1A, SS1B GO TO 0700.
- 050800 IF FMT-NUM-D11X = "4" MOVE 1 TO SS1A GO TO 0800.
- 050900 IF FMT-NUM-D11X NOT = "1"
- 051000 DISPLAY "BAD FORMAT NUMBER" CALL "ABOR".
- 051100 IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-D11X
- 051200 MOVE COL-HDRA11 TO COL-HDR2A1
- 051300 MOVE COL-HDRB11 TO COL-HDR2B1
- 051400 MOVE COL-HDRC11 TO COL-HDR2C1
- 051500 MOVE 1 TO RITE-HDR-FLG.
- 051600 IF SWA-BRWD-D11X NOT = SPACES
- 051700 MOVE SWA-BRWD-D11X TO SWA-BRWD-DL1A11 GO TO 1300.
- 051800 MOVE RNG-SITE-ID-D11AX TO RNG-SITE-ID-DL1A11.
- 051900 MOVE RNG-ECOL-COND-CLS-D11AX TO RNG-ECOL-COND-CLS-DL1A11.
- 052000 MOVE VEG-SUB-TYP-D11AX TO VEG-SUB-TYP-DL1A11.
- 052100 MOVE SWA-PCT-D11AX TO SWA-PCT-DL1A11.
- 052200 MOVE DATA-DAT-D11AX TO DATA-DAT-DL1A11.
- 052300 MOVE RECER-INTLS-D11AX TO RECER-INTLS-DL1A11.
- 052400 MOVE PHOTO-ID-D11AX TO PHOTO-ID-DL1A11.
- 052500 MOVE ADST-CD-CMPR-D11AX TO ADST-CD-CMPR-DL1A11.
- 052600 MOVE DIST-CD-CMPR-D11AX TO DIST-CD-CMPR-DL1A11.
- 052700 MOVE TWP-CMPR-D11AX TO TWP-CMPR-DL1A11.
- 052800 MOVE RNG-CMPR-D11AX TO RNG-CMPR-DL1A11.
- 052900 MOVE CONS-NUM-CMPR-D11AX TO CONS-NUM-CMPR-DL1A11.
- 053000 GO TO 1300.
- 053100 0600.
- 053200 MOVE PLANT-CD-D12AX (SS1A) TO PLANT-CD-DL1A12 (SS1A).
- 053300 IF SS1A < 4 ADD 1 TO SS1A GO TO 0600.
- 053400 MOVE TYP-GC-CD-D12AX TO TYP-GC-CD-DL1A12.
- 053500 MOVE TYP-GC-HITS-D12AX TO TYP-GC-HITS-DL1A12.
- 053600 IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-D11X
- 053700 MOVE COL-HDRA12 TO COL-HDR2A1
- 053800 MOVE COL-HDRB12 TO COL-HDR2B1
- 053900 MOVE COL-HDRC12 TO COL-HDR2C1
- 054000 MOVE 1 TO RITE-HDR-FLG. GO TO 1300.
- 054100 0700.
- 054200 MOVE PLANT-CD-D13AX (SS1A, SS1B)
- 054300 TO PLANT-CD-DL1A13 (SS1A, SS1B).
- 054400 IF SS1B < 4 ADD 1 TO SS1B GO TO 0700.
- 054500 MOVE TYP-GC-HITS-D13AX (SS1A) TO TYP-GC-HITS-DL1A13 (SS1A).
- 054600 IF SS1A < 2 AND PLANT-CDS-TYP-GC-HITS-D13AX NOT = SPACES
- 054700 MOVE 2 TO SS1A MOVE 1 TO SS1B GO TO 0700.
- 054800 IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-D11X
- 054900 MOVE COL-HDRA13 TO COL-HDR2A1
- 055000 MOVE COL-HDRB13 TO COL-HDR2B1
- 055100 MOVE COL-HDRC13 TO COL-HDR2C1
- 055200 MOVE 1 TO RITE-HDR-FLG. GO TO 1300.
- 055300 0800.
- 055400 MOVE SSF-VAL-RAT-D14AX (SS1A) TO SSF-VAL-RAT-DL1A14 (SS1A).
- 055500 IF SS1A < 7 ADD 1 TO SS1A GO TO 0800.
- 055600 IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-D11X
- 055700 MOVE COL-HDRA14 TO COL-HDR2A1
- 055800 MOVE COL-HDRB14 TO COL-HDR2B1
- 055900 MOVE COL-HDRC14 TO COL-HDR2C1
- 056000 MOVE 1 TO RITE-HDR-FLG. GO TO 1300.
- 056100 0900.
- 056200 MOVE PLOT-SIZ-D21AX TO PLOT-SIZ-DL1A21.
- 056300 MOVE PLOT-NUM-D21AX TO PLOT-NUM-DL1A21.
- 056400 MOVE PLANT-CD-D21AX TO PLANT-CD-DL1A21.
- 056500 MOVE AGE-CLS-PLANT-D21AX TO AGE-CLS-PLANT-DL1A21.
- 056600 MOVE FORM-CLS-PLANT-D21AX TO FORM-CLS-PLANT-DL1A21.
- 056700 MOVE PHNO-STG-D21AX TO PHNO-STG-DL1A21.
- 056800 MOVE CLS-PLANT-AVAIL-D21AX TO CLS-PLANT-AVAIL-DL1A21.
- 056900 MOVE CLS-PLANT-UTIL-D21AX TO CLS-PLANT-UTIL-DL1A21.
- 057000 IF AVG-HGT-PLANT-D21AX NOT = SPACES
- 057100 MOVE AVG-HGT-PLANT-INGR-D21AX
- 057200 TO AVG-HGT-PLANT-INGR-DL1A21
- 057300 MOVE "." TO AVG-HGT-PLANT-DEC-DL1A21
- 057400 MOVE AVG-HGT-PLANT-FRC-D21AX TO AVG-HGT-PLANT-FRC-DL1A21.
- 057500 MOVE CHARZD-NUM-D21AX TO CHARZD-NUM-DL1A21.
- 057600 IF AVG-LDR-LGT-D21AX NOT = SPACES
- 057700 MOVE AVG-LDR-LGT-INGR-D21AX TO AVG-LDR-LGT-INGR-DL1A21
- 057800 MOVE "." TO AVG-LDR-LGT-DEC-DL1A21
- 057900 MOVE AVG-LDR-LGT-FRC-D21AX TO AVG-LDR-LGT-FRC-DL1A21.
- 058000 IF AVG-CRN-DIA-D21AX NOT = SPACES
- 058100 MOVE AVG-CRN-DIA-INGR-D21AX TO AVG-CRN-DIA-INGR-DL1A21
- 058200 MOVE "." TO AVG-CRN-DIA-DEC-DL1A21
- 058300 MOVE AVG-CRN-DIA-FRC-D21AX TO AVG-CRN-DIA-FRC-DL1A21.
- 058400 MOVE CHARZD-NOT-NUM-D21AX TO CHARZD-NOT-NUM-DL1A21.
- 058500 MOVE MAST-CROPS-CD-D21AX TO MAST-CROPS-CD-DL1A21.
- 058600 IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-D11X
- 058700 MOVE COL-HDRA21 TO COL-HDR2A1
- 058800 MOVE COL-HDRB21 TO COL-HDR2B1
- 058900 MOVE COL-HDRC21 TO COL-HDR2C1
- 059000 MOVE 1 TO RITE-HDR-FLG. GO TO 1300.
- 059100 1000.
- 059200 IF FMT-CD-D11X = "B" GO TO 1200.
- 059300 IF FMT-CD-D11X NOT = "A"
- 059400 DISPLAY "BAD FORMAT CODE" CALL "ABOR".
- 059500 MOVE PLOT-TOT-NUM-V3XAX TO PLOT-TOT-NUM-DL1A3A.
- 059600 IF PLOT-SIZ-EST-V3XAX NOT = SPACES
- 059700 MOVE PLOT-SIZ-EST-INGR-V3XAX TO PLOT-SIZ-EST-INGR-DL1A3A
- 059800 MOVE "." TO PLOT-SIZ-EST-DEC-DL1A3A
- 059900 MOVE PLOT-SIZ-EST-FRC-V3XAX TO PLOT-SIZ-EST-FRC-DL1A3A.
- 060000 MOVE PLANT-CD-V3XAX TO PLANT-CD-DL1A3A.
- 060100 MOVE HGT-CLS-CD-V3XAX TO HGT-CLS-CD-DL1A3A.
- 060200 1100.
- 060300 MOVE HRBG-PROD-WGT-V3XAX (SS2A)
- 060400 TO HRBG-PROD-WGT-DL1A3A (SS2A).
- 060500 IF SS2A < 10 ADD 1 TO SS2A GO TO 1100.
- 060600 MOVE FMT-NUM-D11X TO FMT-NUM-DL1A.
- 060700 IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-D11X
- 060800 MOVE COL-HDRA3A TO COL-HDR2A1
- 060900 MOVE COL-HDRB3A TO COL-HDR2B1
- 061000 MOVE COL-HDRC3A TO COL-HDR2C1
- 061100 MOVE 1 TO RITE-HDR-FLG. GO TO 1300.
- 061200 1200.
- 061300 MOVE GRP-V3XBX (SS2A) TO GRP2-DL1A3B (SS2A).
- 061400 IF SS2A < 10 ADD 1 TO SS2A GO TO 1200.
- 061500 MOVE PLOT-TOT-NUM-V3XBX TO PLOT-TOT-NUM-DL1A3B.
- 061600 IF PLOT-SIZ-EST-V3XBX NOT = SPACES
- 061700 MOVE PLOT-SIZ-EST-INGR-V3XBX TO PLOT-SIZ-EST-INGR-DL1A3B
- 061800 MOVE "." TO PLOT-SIZ-EST-DEC-DL1A3B
- 061900 MOVE PLOT-SIZ-EST-FRC-V3XBX TO PLOT-SIZ-EST-FRC-DL1A3B.
- 062000 MOVE PLANT-CD-V3XBX TO PLANT-CD-DL1A3B.
- 062100 MOVE HGT-CLS-CD-V3XBX TO HGT-CLS-CD-DL1A3B.
- 062200 MOVE FMT-NUM-D11X TO FMT-NUM-DL1A.
- 062300 IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-D11X
- 062400 MOVE COL-HDRA3B TO COL-HDR2A1
- 062500 MOVE COL-HDRB3B TO COL-HDR2B1
- 062600 MOVE COL-HDRC3B TO COL-HDR2C1
- 062700 MOVE 1 TO RITE-HDR-FLG.
- 062800 1300.
- 062900 MOVE REC-TYP-T-FMT-CD-D11X
- 063000 TO REC-TYP-T-FMT-CD-DL1A.
- 063100 MOVE ACTN-CD-D11X TO ACTN-CD-DL1A.
- 063200 MOVE LIN-NUM-D11X TO LIN-NUM-DL1A.
- 063300 1400.
- 063400 MOVE ZERO TO LIN-CNTR.
- 063500 IF RITE-HDR-FLG NOT ZERO ADD 4 TO LIN-CNTR.
- 063600 IF RITE-KEY-FLG NOT ZERO ADD 6 TO LIN-CNTR.
- 063700 ADD 2 TO LIN-CNTR. ADD LIN-CNTR TO LIN-CHK.
- 063800 IF LIN-CHK > 52 ADD 1 TO PAG-CNTR
- 063900 MOVE PAG-CNTR TO PAG-CNT-PH1 MOVE ZERO TO LIN-CHK
- 064000 MOVE 1 TO RITE-HDR-FLG, RITE-KEY-FLG
- 064100 MOVE PAG-HDR1 TO REC-P1
- 064200 WRITE REC-P1 AFTER ADVANCING PAGE
- 064300 MOVE PAG-HDR2 TO REC-P1
- 064400 WRITE REC-P1 AFTER ADVANCING 2 LINES
- 064500 MOVE SPACES TO REC-P1 WRITE REC-P1 GO TO 1400.
- 064600 IF RITE-KEY-FLG ZERO GO TO 1500.
- 064700 MOVE ZERO TO RITE-KEY-FLG.
- 064800 MOVE COL-HDR1A TO REC-P1.
- 064900 WRITE REC-P1 AFTER ADVANCING 2 LINES.
- 065000 MOVE COL-HDR1B TO REC-P1. WRITE REC-P1.
- 065100 MOVE COL-HDR1C TO REC-P1. WRITE REC-P1.
- 065200 MOVE KEY-LIN1A TO REC-P1.
- 065300 WRITE REC-P1 AFTER ADVANCING 2 LINES.
- 065400 1500.
- 065500 IF RITE-HDR-FLG NOT ZERO
- 065600 MOVE ZERO TO RITE-HDR-FLG
- 065700 MOVE COL-HDR2A TO REC-P1
- 065800 WRITE REC-P1 AFTER ADVANCING 2 LINES
- 065900 MOVE COL-HDR2B TO REC-P1 WRITE REC-P1
- 066000 MOVE COL-HDR2C TO REC-P1 WRITE REC-P1.
- 066100 MOVE DATA-LIN1A TO REC-P1.
- 066200 WRITE REC-P1 AFTER ADVANCING 2 LINES.
- 066300 MOVE SPACES TO DATA-LIN1A11. GO TO 0400.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES030E.
- 000300* VEGETATIVE EDIT AND ERROR LIST
- 000400*
- 000500 AUTHOR. CHUCK SLIZEWSKI.
- 000600 DATE-WRITTEN. 01/10/79.
- 000700 DATE-COMPILED.
- 000800 ENVIRONMENT DIVISION.
- 000900 CONFIGURATION SECTION.
- 001000 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001100 OBJECT-COMPUTER. LEVEL-66-ASCII.
- 001200 INPUT-OUTPUT SECTION.
- 001300 FILE-CONTROL.
- 001400 SELECT FIL-I1 ASSIGN TO I1
- 001500 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001600 SELECT FIL-D1 ASSIGN TO D1
- 001700 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001800 SELECT FIL-P1 ASSIGN TO P1
- 001900 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002000 DATA DIVISION.
- 002100 SUB-SCHEMA SECTION.
- 002200 DB CODVAL2 WITHIN BLMDIC.
- 002300 FILE SECTION.
- 002400 FD FIL-I1
- 002500 CODE-SET IS GBCD
- 002600 LABEL RECORDS ARE STANDARD
- 002700 DATA RECORD IS REC-I1.
- 002800 01 REC-I1.
- 002900 03 FILLER PIC X(8).
- 003000 03 SDP-I1 PIC X(6).
- 003100 03 FILLER PIC X(130).
- 003200 FD FIL-D1
- 003300 CODE-SET IS GBCD
- 003400 LABEL RECORDS ARE STANDARD
- 003500 DATA RECORD IS REC-D1.
- 003600 01 REC-D1 PIC X(144).
- 003700 FD FIL-P1
- 003800 CODE-SET IS GBCD
- 003900 LABEL RECORDS ARE STANDARD
- 004000 DATA RECORD IS REC-P1.
- 004100 01 REC-P1 PIC X(132).
- 004200 WORKING-STORAGE SECTION.
- 004300 77 CNT-BAD-TYPE PIC 9(6) VALUE ZERO.
- 004400 77 CNT-BAD-FORM PIC 9(6) VALUE ZERO.
- 004500 77 CNT-BAD-CODE PIC 9(6) VALUE ZERO.
- 004600 77 CNT-V1 PIC 9(6) VALUE ZERO.
- 004700 77 CNT-V2 PIC 9(6) VALUE ZERO.
- 004800 77 CNT-V3 PIC 9(6) VALUE ZERO.
- 004900 77 CNT-BAD-PU PIC 9(6) VALUE ZERO.
- 005000 77 CNT-BAD-ALOT PIC 9(6) VALUE ZERO.
- 005100 77 DATA-FLG PIC 9 COMP-4 VALUE ZERO.
- 005200 77 PLT-HLD PIC X(7) VALUE SPACE.
- 005300 77 PLT-SRC PIC X(7) VALUE SPACE.
- 005400 77 FRC-FLG PIC 9 COMP-4.
- 005500 77 IN-CNTR PIC 9(6) COMP-4 VALUE ZERO.
- 005600 77 INGR-FLG PIC 9 COMP-4.
- 005700 77 KEY-FLG PIC 9 COMP-4.
- 005800 77 LIN-CHK PIC 99 COMP-4.
- 005900 77 LIN-CNT PIC 99 COMP-4.
- 006000 77 LIN-NUM-H PIC 999.
- 006100 77 OT-CNTR PIC 9(6) COMP-4 VALUE ZERO.
- 006200 77 PAG-CNT PIC 999 COMP-4.
- 006300 77 PLANT-CD-FLG PIC 9 COMP-4.
- 006400 77 PT-CNTR PIC 9(6) COMP-4 VALUE ZERO.
- 006500 77 RITE-HDR-FLG PIC 9 COMP-4.
- 006600 77 RITE-KEY-FLG PIC 9 COMP-4.
- 006700 77 SS1A PIC 9 COMP-4.
- 006800 77 SS1B PIC 9 COMP-4.
- 006900 77 SS1C PIC 9 COMP-4.
- 007000 77 SS1D PIC 9 COMP-4.
- 007100 77 SS2A PIC 99 COMP-4.
- 007200 77 PLT-SUB PIC 9(6) VALUE ZERO.
- 007300 01 PLT-TABLE.
- 007400 03 PLT-TB PIC X(7) OCCURS 200 TIMES.
- 007500 01 PLT-TABLE-2.
- 007600 03 PLT-CNT PIC 999 OCCURS 200 TIMES.
- 007700 01 COL-HDR1A.
- 007800 03 FILLER PIC X(24) VALUE " ST DIST PL".
- 007900 03 FILLER PIC X(24) VALUE "U ALLOT SWA TRN ".
- 008000 03 FILLER PIC X(84) VALUE SPACES.
- 008100 01 COL-HDR1B.
- 008200 03 FILLER PIC X(24) VALUE " 9-10 11-12 13-".
- 008300 03 FILLER PIC X(24) VALUE "14 15-18 19-22 23-24".
- 008400 03 FILLER PIC X(84) VALUE SPACES.
- 008500 01 COL-HDR1C.
- 008600 03 FILLER PIC X(24) VALUE " XX XX XX".
- 008700 03 FILLER PIC X(24) VALUE " XXXX XXXX XX ".
- 008800 03 FILLER PIC X(84) VALUE SPACES.
- 008900 01 COL-HDRA11 PIC X(108) VALUE "O SWA/T RNG SITE CC VEG S
- 009000- "-TYP % SWA DATE RECR A/PHOTO
- 009100- "CMPR: ST DIST TWP RNG NUM ".
- 009200 01 COL-HDRB11 PIC X(108) VALUE "30-35 45-55 56 57-
- 009300- "60 61-63 64-69 70-72 73-88
- 009400- " 89-90 91-92 93-97 98-102 103-104 ".
- 009500 01 COL-HDRC11 PIC X(108) VALUE "XXXXXX XXXXXXXXXXX X XXX
- 009600- "X XXX XXXXXX XXX XXXXXXXXXXXXX
- 009700- "XXX XX XX XXXXX XXXXX XX ".
- 009800 01 COL-HDRA12 PIC X(108) VALUE "GRND CVR BASAL NUM - - - -
- 009900- " -O B S E R V E D S P E C I E S- - - -
- 010000- " - ".
- 010100 01 COL-HDRB12 PIC X(108) VALUE " DATA: 45 46-48 49-55
- 010200- " 56-62 63-69 70-7
- 010300- "6 ".
- 010400 01 COL-HDRC12 PIC X(108) VALUE " X XXX XXXXXXX
- 010500- " XXXXXXX XXXXXXX XXXXX
- 010600- "XX ".
- 010700 01 COL-HDRA13 PIC X(108) VALUE " BASAL CANOPY 1 CANOPY 2
- 010800- " CANOPY 3 NUM BASAL CANOPY 1
- 010900- " CANOPY 2 CANOPY 3 NUM ".
- 011000 01 COL-HDRB13 PIC X(108) VALUE " 45-53 54-62 63-71
- 011100- " 72-80 81-83 84-92 93-101
- 011200- " 102-110 111-119 120-122 ".
- 011300 01 COL-HDRC13 PIC X(108) VALUE "XXXXXXXXX XXXXXXXXX XXXXXXXX
- 011400- "X XXXXXXXXX XXX XXXXXXXXX XXXXXXXX
- 011500- "X XXXXXXXXX XXXXXXXXX XXX ".
- 011600 01 COL-HDRA14 PIC X(108) VALUE "SOIL MVMT SOIL LITR SURF ROC
- 011700- "K PEDESTALL FLOW PTRN RILLS GUL
- 011800- "LIES ".
- 011900 01 COL-HDRB14 PIC X(108) VALUE " 45-46 47-48 49-50
- 012000- " 51-52 53-54 55-56 57
- 012100- "-58 ".
- 012200 01 COL-HDRC14 PIC X(108) VALUE " XX XX XX
- 012300- " XX XX XX X
- 012400- "X ".
- 012500 01 COL-HDRA21 PIC X(108) VALUE "SIZ/PLOT/NUM SPECIES AGE/CL
- 012600- "ASS/FORM PHNO AVAIL UTIL HGT D/CNT
- 012700- " L/LGT CROWN DIA N/CHARZD M/CROPS ".
- 012800 01 COL-HDRB21 PIC X(108) VALUE "45 46-47 48-54 55
- 012900- " 56 57 58 59 60-64 65-67
- 013000- " 68-72 73-77 78-80 81 ".
- 013100 01 COL-HDRC21 PIC X(108) VALUE " X XX XXXXXXX X
- 013200- " X X X X XXX XX XXX
- 013300- " XXX XX XXX XX XXX X ".
- 013400 01 COL-HDRA3B PIC X(108) VALUE "NUM/PLOT/SIZ SPECIES HGT WE
- 013500- " 1 2 3 4 5
- 013600- " 6 7 8 9 10 ".
- 013700 01 COL-HDRB3B PIC X(108) VALUE "45-46 47-53 54-60 61 D: 6
- 013800- "2-68 69-75 76-82 83-89 90-96 97
- 013900- "-103 104-110 111-117 118-124 125-131 ".
- 014000 01 COL-HDRC3B PIC X(108) VALUE " XX XXXXX XX XXXXXXX X XX
- 014100- "XXXXX XXXXXXX XXXXXXX XXXXXXX XXXXXXX XX
- 014200- "XXXXX XXXXXXX XXXXXXX XXXXXXX XXXXXXX ".
- 014300 01 COL-HDR2A.
- 014400 03 FILLER PIC X(24) VALUE "REC TYP ACTN LIN NUM ".
- 014500 03 COL-HDR2A1 PIC X(108).
- 014600 01 COL-HDR2B.
- 014700 03 FILLER PIC X(24) VALUE " 5-8 25 26-28 ".
- 014800 03 COL-HDR2B1 PIC X(108).
- 014900 01 COL-HDR2C.
- 015000 03 FILLER PIC X(24) VALUE " XXXX X XXX ".
- 015100 03 COL-HDR2C1 PIC X(108).
- 015200 01 DATA-LIN1A VALUE SPACES.
- 015300 03 FILLER PIC X.
- 015400 03 REC-TYP-T-FMT-CD-DL1A.
- 015500 05 FILLER PIC XX.
- 015600 05 FMT-NUM-DL1A PIC X.
- 015700 05 FILLER PIC X.
- 015800 03 FILLER PIC X(5).
- 015900 03 ACTN-CD-DL1A PIC X.
- 016000 03 FILLER PIC X(6).
- 016100 03 LIN-NUM-DL1A PIC XXX.
- 016200 03 FILLER PIC XXXX.
- 016300 03 DATA-LIN1A11.
- 016400 05 SWA-BRWD-DL1A11 PIC X(6).
- 016500 05 FILLER PIC XX.
- 016600 05 RNG-SITE-ID-DL1A11 PIC X(11).
- 016700 05 FILLER PIC XX.
- 016800 05 RNG-ECOL-COND-CLS-DL1A11 PIC X.
- 016900 05 FILLER PIC X(5).
- 017000 05 VEG-SUB-TYP-DL1A11 PIC XXXX.
- 017100 05 FILLER PIC X(6).
- 017200 05 SWA-PCT-DL1A11 PIC XXX.
- 017300 05 FILLER PIC XXX.
- 017400 05 DATA-DAT-DL1A11 PIC X(6).
- 017500 05 FILLER PIC XXX.
- 017600 05 RECER-INTLS-DL1A11 PIC XXX.
- 017700 05 FILLER PIC XX.
- 017800 05 PHOTO-ID-DL1A11 PIC X(16).
- 017900 05 FILLER PIC XXX.
- 018000 05 ADST-CD-CMPR-DL1A11 PIC XX.
- 018100 05 FILLER PIC XXXX.
- 018200 05 DIST-CD-CMPR-DL1A11 PIC XX.
- 018300 05 FILLER PIC XXX.
- 018400 05 TWP-CMPR-DL1A11 PIC X(5).
- 018500 05 FILLER PIC X.
- 018600 05 RNG-CMPR-DL1A11 PIC X(5).
- 018700 05 FILLER PIC XXXX.
- 018800 05 CONS-NUM-CMPR-DL1A11 PIC XX.
- 018900 05 FILLER PIC XXXX.
- 019000 03 DATA-LIN1A12 REDEFINES DATA-LIN1A11.
- 019100 05 FILLER PIC X(10).
- 019200 05 TYP-GC-CD-DL1A12 PIC X.
- 019300 05 FILLER PIC X(5).
- 019400 05 TYP-GC-HITS-DL1A12 PIC XXX.
- 019500 05 FILLER PIC XXXX.
- 019600 05 GRP-DL1A12 OCCURS 4 TIMES.
- 019700 07 PLANT-CD-DL1A12 PIC X(7).
- 019800 07 FILLER PIC X(7).
- 019900 05 FILLER PIC X(29).
- 020000 03 DATA-LIN1A13 REDEFINES DATA-LIN1A11.
- 020100 05 GRP1-DL1A13 OCCURS 2 TIMES.
- 020200 07 GRP2-DL1A13 OCCURS 4 TIMES.
- 020300 09 PLANT-CD-DL1A13 PIC X(9).
- 020400 09 FILLER PIC XX.
- 020500 07 TYP-GC-HITS-DL1A13 PIC XXX.
- 020600 07 FILLER PIC XXXX.
- 020700 05 FILLER PIC X(6).
- 020800 03 DATA-LIN1A14 REDEFINES DATA-LIN1A11.
- 020900 05 FILLER PIC XXX.
- 021000 05 GRP-DL1A14 OCCURS 7 TIMES.
- 021100 07 SSF-VAL-RAT-DL1A14 PIC XX.
- 021200 07 FILLER PIC X(9).
- 021300 05 FILLER PIC X(28).
- 021400 03 DATA-LIN1A21 REDEFINES DATA-LIN1A11.
- 021500 05 FILLER PIC X.
- 021600 05 PLOT-SIZ-DL1A21 PIC X.
- 021700 05 FILLER PIC X(7).
- 021800 05 PLOT-NUM-DL1A21 PIC XX.
- 021900 05 FILLER PIC XXXX.
- 022000 05 PLANT-CD-DL1A21 PIC X(7).
- 022100 05 FILLER PIC XXX.
- 022200 05 AGE-CLS-PLANT-DL1A21 PIC X.
- 022300 05 FILLER PIC X(9).
- 022400 05 FORM-CLS-PLANT-DL1A21 PIC X.
- 022500 05 FILLER PIC X(5).
- 022600 05 PHNO-STG-DL1A21 PIC X.
- 022700 05 FILLER PIC X(6).
- 022800 05 CLS-PLANT-AVAIL-DL1A21 PIC X.
- 022900 05 FILLER PIC X(5).
- 023000 05 CLS-PLANT-UTIL-DL1A21 PIC X.
- 023100 05 FILLER PIC XXX.
- 023200 05 AVG-HGT-PLANT-INGR-DL1A21 PIC XXX.
- 023300 05 AVG-HGT-PLANT-DEC-DL1A21 PIC X.
- 023400 05 AVG-HGT-PLANT-FRC-DL1A21 PIC XX.
- 023500 05 FILLER PIC XX.
- 023600 05 CHARZD-NUM-DL1A21 PIC XXX.
- 023700 05 FILLER PIC XXX.
- 023800 05 AVG-LDR-LGT-INGR-DL1A21 PIC XXX.
- 023900 05 AVG-LDR-LGT-DEC-DL1A21 PIC X.
- 024000 05 AVG-LDR-LGT-FRC-DL1A21 PIC XX.
- 024100 05 FILLER PIC XXX.
- 024200 05 AVG-CRN-DIA-INGR-DL1A21 PIC XXX.
- 024300 05 AVG-CRN-DIA-DEC-DL1A21 PIC X.
- 024400 05 AVG-CRN-DIA-FRC-DL1A21 PIC XX.
- 024500 05 FILLER PIC X(5).
- 024600 05 CHARZD-NOT-NUM-DL1A21 PIC XXX.
- 024700 05 FILLER PIC X(8).
- 024800 05 MAST-CROPS-CD-DL1A21 PIC X.
- 024900 05 FILLER PIC XXXX.
- 025000 03 DATA-LIN1A3B REDEFINES DATA-LIN1A11.
- 025100 05 FILLER PIC X.
- 025200 05 PLOT-TOT-NUM-DL1A3B PIC XX.
- 025300 05 FILLER PIC X.
- 025400 05 PLOT-SIZ-EST-INGR-DL1A3B PIC X(5).
- 025500 05 PLOT-SIZ-EST-DEC-DL1A3B PIC X.
- 025600 05 PLOT-SIZ-EST-FRC-DL1A3B PIC XX.
- 025700 05 FILLER PIC X.
- 025800 05 PLANT-CD-DL1A3B PIC X(7).
- 025900 05 FILLER PIC XX.
- 026000 05 HGT-CLS-CD-DL1A3B PIC X.
- 026100 05 FILLER PIC X(5).
- 026200 05 GRP1-DL1A3B OCCURS 10 TIMES.
- 026300 07 GRP2-DL1A3B PIC X(7).
- 026400 07 FILLER PIC X.
- 026500 01 DATA-LIN1B VALUE SPACES.
- 026600 03 FILLER PIC X(17).
- 026700 03 DATA-LIN1B11.
- 026800 05 LIN-NUM-DL1B PIC XXX.
- 026900 05 FILLER PIC XXXX.
- 027000 05 SWA-CD-BRWD-DL1B11 PIC X.
- 027100 05 SWA-NUM-BRWD-DL1B11 PIC XXX.
- 027200 05 TRN-NUM-BRWD-DL1B11 PIC XX.
- 027300 05 FILLER PIC XX.
- 027400 05 RNG-SITE-ID-DL1B11 PIC X(11).
- 027500 05 FILLER PIC XX.
- 027600 05 RNG-ECOL-COND-CLS-DL1B11 PIC X.
- 027700 05 FILLER PIC X(5).
- 027800 05 VEG-SUB-TYP-DL1B11 PIC XXXX.
- 027900 05 FILLER PIC X(6).
- 028000 05 SWA-PCT-DL1B11 PIC XXX.
- 028100 05 FILLER PIC XXX.
- 028200 05 DATA-DAT-DL1B11.
- 028300 07 DATA-YER-DL1B11 PIC XX.
- 028400 07 DATA-MON-DL1B11 PIC XX.
- 028500 07 DATA-DAY-DL1B11 PIC XX.
- 028600 05 FILLER PIC XXX.
- 028700 05 RECER-INTLS-DL1B11 PIC XXX.
- 028800 05 FILLER PIC XX.
- 028900 05 PHOTO-ID-DL1B11 PIC X(16).
- 029000 05 FILLER PIC XXX.
- 029100 05 ADST-CD-CMPR-DL1B11 PIC XX.
- 029200 05 FILLER PIC XXXX.
- 029300 05 DIST-CD-CMPR-DL1B11 PIC XX.
- 029400 05 FILLER PIC XXX.
- 029500 05 TWP-CMPR-DL1B11 PIC X(5).
- 029600 05 FILLER PIC X.
- 029700 05 RNG-CMPR-DL1B11 PIC X(5).
- 029800 05 FILLER PIC XXXX.
- 029900 05 CONS-NUM-CMPR-DL1B11 PIC XX.
- 030000 05 FILLER PIC XXXX.
- 030100 03 DATA-LIN1B12 REDEFINES DATA-LIN1B11.
- 030200 05 FILLER PIC X(17).
- 030300 05 TYP-GC-CD-DL1B12 PIC X.
- 030400 05 FILLER PIC X(5).
- 030500 05 TYP-GC-HITS-DL1B12 PIC XXX.
- 030600 05 FILLER PIC XXXX.
- 030700 05 GRP-DL1B12 OCCURS 4 TIMES.
- 030800 07 PLANT-CD-DL1B12 PIC X(7).
- 030900 07 FILLER PIC X(7).
- 031000 05 FILLER PIC X(29).
- 031100 03 DATA-LIN1B13 REDEFINES DATA-LIN1B11.
- 031200 05 FILLER PIC X(7).
- 031300 05 GRP1-DL1B13 OCCURS 2 TIMES.
- 031400 07 GRP2-DL1B13 OCCURS 4 TIMES.
- 031500 09 PLANT-CD-DL1B13 PIC X(9).
- 031600 09 FILLER PIC XX.
- 031700 07 TYP-GC-HITS-DL1B13 PIC XXX.
- 031800 07 FILLER PIC XXXX.
- 031900 05 FILLER PIC X(6).
- 032000 03 DATA-LIN1B14 REDEFINES DATA-LIN1B11.
- 032100 05 FILLER PIC X(10).
- 032200 05 GRP-DL1B14 OCCURS 7 TIMES.
- 032300 07 SSF-VAL-RAT-DL1B14 PIC XX.
- 032400 07 FILLER PIC X(9).
- 032500 05 FILLER PIC X(28).
- 032600 03 DATA-LIN1B21 REDEFINES DATA-LIN1B11.
- 032700 05 FILLER PIC X(8).
- 032800 05 PLOT-SIZ-DL1B21 PIC X.
- 032900 05 FILLER PIC X(7).
- 033000 05 PLOT-NUM-DL1B21 PIC XX.
- 033100 05 FILLER PIC XXXX.
- 033200 05 PLANT-CD-DL1B21 PIC X(7).
- 033300 05 FILLER PIC XXX.
- 033400 05 AGE-CLS-PLANT-DL1B21 PIC X.
- 033500 05 FILLER PIC X(9).
- 033600 05 FORM-CLS-PLANT-DL1B21 PIC X.
- 033700 05 FILLER PIC X(5).
- 033800 05 PHNO-STG-DL1B21 PIC X.
- 033900 05 FILLER PIC X(6).
- 034000 05 CLS-PLANT-AVAIL-DL1B21 PIC X.
- 034100 05 FILLER PIC X(5).
- 034200 05 CLS-PLANT-UTIL-DL1B21 PIC X.
- 034300 05 FILLER PIC XXX.
- 034400 05 AVG-HGT-PLANT-INGR-DL1B21 PIC XXX.
- 034500 05 FILLER PIC X.
- 034600 05 AVG-HGT-PLANT-FRC-DL1B21 PIC XX.
- 034700 05 FILLER PIC XX.
- 034800 05 CHARZD-NUM-DL1B21 PIC XXX.
- 034900 05 FILLER PIC XXX.
- 035000 05 AVG-LDR-LGT-INGR-DL1B21 PIC XXX.
- 035100 05 FILLER PIC X.
- 035200 05 AVG-LDR-LGT-FRC-DL1B21 PIC XX.
- 035300 05 FILLER PIC XXX.
- 035400 05 AVG-CRN-DIA-INGR-DL1B21 PIC XXX.
- 035500 05 FILLER PIC X.
- 035600 05 AVG-CRN-DIA-FRC-DL1B21 PIC XX.
- 035700 05 FILLER PIC X(5).
- 035800 05 CHARZD-NOT-NUM-DL1B21 PIC XXX.
- 035900 05 FILLER PIC X(8).
- 036000 05 MAST-CROPS-CD-DL1B21 PIC X.
- 036100 05 FILLER PIC XXXX.
- 036200 03 DATA-LIN1B3B REDEFINES DATA-LIN1B11.
- 036300 05 FILLER PIC X(8).
- 036400 05 PLOT-TOT-NUM-DL1B3B PIC XX.
- 036500 05 FILLER PIC X.
- 036600 05 PLOT-SIZ-EST-INGR-DL1B3B PIC X(5).
- 036700 05 FILLER PIC X.
- 036800 05 PLOT-SIZ-EST-FRC-DL1B3B PIC XX.
- 036900 05 FILLER PIC X.
- 037000 05 PLANT-CD-DL1B3B PIC X(7).
- 037100 05 FILLER PIC XX.
- 037200 05 HGT-CLS-CD-DL1B3B PIC X.
- 037300 05 FILLER PIC X(5).
- 037400 05 GRP1-DL1B3B OCCURS 10 TIMES.
- 037500 07 CLS-PLANT-AVAIL-DL1B3B PIC X.
- 037600 07 PHNO-STG-DL1B3B PIC X.
- 037700 07 CLS-PLANT-UTIL-DL1B3B PIC X.
- 037800 07 HRBG-PROD-WGT-DL1B3B PIC XXXX.
- 037900 07 FILLER PIC X.
- 038000 01 HOLD-AREA.
- 038100 03 ADST-CD-T-ACTN-CD-V11H.
- 038200 05 ADST-CD-T-TRN-NUM-V11H.
- 038300 07 ADST-DIST-PLU-CDS-V11H.
- 038400 09 ADST-CD-V11H PIC XX VALUE SPACES.
- 038500 09 DIST-CD-V11H PIC XX.
- 038600 09 PLU-CD-V11H PIC XX.
- 038700 07 ALLOT-NUM-T-TRN-NUM-V11H.
- 038800 09 ALLOT-NUM-V11H PIC XXXX.
- 038900 09 SWA-V11H.
- 039000 11 SWA-CD-V11H PIC X.
- 039100 11 SWA-NUM-V11H PIC XXX.
- 039200 09 TRN-NUM-V11H PIC XX.
- 039300 05 REC-TYP-T-FMT-CD-V11H PIC XXXX.
- 039400 05 ACTN-CD-V11H PIC X.
- 039500 03 ADST-CD-T-ACTN-CD-V11X-H PIC X(21).
- 039600 03 ADST-DIST-RA-PLU-CDS-H.
- 039700 05 ADST-DIST-CDS-H.
- 039800 07 ADST-CD-H PIC XX.
- 039900 07 DIST-CD-H PIC XX.
- 040000 05 RA-CD-H.
- 040100 07 RA-CD-C1-H PIC 9.
- 040200 07 FILLER PIC 9 VALUE 8.
- 040300 05 PLU-CD-H PIC XX.
- 040400 03 DE-CD-EXPLN-8827-DECE-H.
- 040500 05 DIST-NAM-H PIC X(12).
- 040600 05 RA-NAM-H PIC X(13).
- 040700 05 PLU-NAM-H PIC X(15).
- 040800 03 CODE-DEC-H.
- 040900 05 FILLER PIC XXXX.
- 041000 05 PLANT-CD-H PIC X(7).
- 041100 05 FILLER PIC X(24).
- 041200 05 PLANT-TYP-H PIC X.
- 041300 03 DE-CD-NAM-8823-DEC-H.
- 041400 05 ST-NAM-H PIC X(10).
- 041500 05 FILLER PIC X(14).
- 041600 03 DAT-H.
- 041700 05 YER-H PIC XX.
- 041800 05 MON-H PIC 99.
- 041900 05 DAY-H PIC XX.
- 042000 03 GRP-V3XBX-H.
- 042100 05 CLS-PLANT-AVAIL-V3XBX-H PIC X.
- 042200 05 PHNO-STG-V3XBX-H PIC X.
- 042300 05 CLS-PLANT-UTIL-V3XBX-H PIC X.
- 042400 05 HRBG-PROD-WGT-V3XBX-H PIC XXXX.
- 042500 03 INGR-3C-FRC-2C-H PIC 999V99.
- 042600 03 I3F2-H REDEFINES INGR-3C-FRC-2C-H.
- 042700 05 INGR-3C-FRC-1C-H PIC 999V9.
- 042800 05 I3F1-H REDEFINES INGR-3C-FRC-1C-H.
- 042900 07 FILLER PIC X.
- 043000 07 INGR-2C-FRC-1C-H PIC 99V9.
- 043100 05 FILLER PIC X.
- 043200 03 INGR-FRC-H REDEFINES INGR-3C-FRC-2C-H.
- 043300 05 INGR-H PIC XXX.
- 043400 05 FRC-H PIC XX.
- 043500 03 PLANT-CD-V13AX-H.
- 043600 05 PLANT-CD-C1-V13AX-H PIC X.
- 043700 05 PLANT-CD-LST-8C-V13AX-H PIC X(8).
- 043800 03 PC-V13AX-H REDEFINES PLANT-CD-V13AX-H.
- 043900 05 PLANT-CD-1ST-8C-V13AX-H PIC X(8).
- 044000 05 FILLER PIC X.
- 044100 03 1C-PLANT-CD-V13AX-H REDEFINES PLANT-CD-V13AX-H
- 044200 PIC X OCCURS 9 TIMES.
- 044300 03 PLANT-CD-V13AZ-H.
- 044400 05 PLANT-CD-1ST-7C-V13AZ-H.
- 044500 07 PLANT-CD-C1-V13AZ-H PIC X.
- 044600 07 PLANT-CD-C2T7-V13AZ-H PIC X(6).
- 044700 05 1C-PLANT-CD-V13AZ-H REDEFINES
- 044800 PLANT-CD-1ST-7C-V13AZ-H PIC X OCCURS 7 TIMES.
- 044900 05 LEV-TRN-HIT-V13AZ-H PIC X.
- 045000 05 FILLER PIC X.
- 045100 03 PLOT-SIZ-EST-V3XBX-H.
- 045200 05 FILLER PIC XX.
- 045300 05 PLOT-SIZ-EST-D3XBZ-H PIC 999V99.
- 045400 05 PLOT-SIZ-C3T7-V3XBX-H REDEFINES
- 045500 PLOT-SIZ-EST-D3XBZ-H.
- 045600 07 PLOT-SIZ-C3T5-V3XBX-H PIC XXX.
- 045700 07 PLOT-SIZ-C6T7-V3XBX-H PIC XX.
- 045800 03 SSF-VAL-RAT-V14AX-H PIC XX.
- 045900 03 TYP-GC-HITS-V13AX-H PIC XXX.
- 046000 03 1C-PLANT-CD-H PIC X.
- 046100 01 KEY-LIN1A.
- 046200 03 FILLER PIC X(10) VALUE SPACES.
- 046300 03 ADST-CD-KL1A PIC XX.
- 046400 03 FILLER PIC XXXX VALUE SPACES.
- 046500 03 DIST-CD-KL1A PIC XX.
- 046600 03 FILLER PIC XXXX VALUE SPACES.
- 046700 03 PLU-CD-KL1A PIC XX.
- 046800 03 FILLER PIC XXXX VALUE SPACES.
- 046900 03 ALLOT-NUM-KL1A PIC XXXX.
- 047000 03 FILLER PIC XXXX VALUE SPACES.
- 047100 03 SWA-KL1A PIC XXXX.
- 047200 03 FILLER PIC XXXX VALUE SPACES.
- 047300 03 TRN-NUM-KL1A PIC XX.
- 047400 03 FILLER PIC X(86) VALUE SPACES.
- 047500 01 KEY-LIN1B.
- 047600 03 FILLER PIC X(10) VALUE SPACES.
- 047700 03 KEY-LIN1B1.
- 047800 05 ADST-CD-KL1B PIC XX.
- 047900 05 FILLER PIC XXXX.
- 048000 05 DIST-CD-KL1B PIC XX.
- 048100 05 FILLER PIC XXXX.
- 048200 05 PLU-CD-KL1B PIC XX.
- 048300 03 FILLER PIC XXXX VALUE SPACES.
- 048400 03 KEY-LIN1B2.
- 048500 05 ALLOT-NUM-KL1B PIC XXXX.
- 048600 05 FILLER PIC XXXX.
- 048700 05 SWA-CD-KL1B PIC X.
- 048800 05 SWA-NUM-KL1B PIC XXX.
- 048900 05 FILLER PIC XXXX.
- 049000 05 TRN-NUM-KL1B PIC XX.
- 049100 03 FILLER PIC X(86) VALUE SPACES.
- 049200 01 LTRL-AREA.
- 049300 03 10ASTRKS-L VALUE ALL "*".
- 049400 05 09ASTRKS-L.
- 049500 07 07ASTRKS-L.
- 049600 09 06ASTRKS-L.
- 049700 11 05ASTRKS-L.
- 049800 13 04ASTRKS-L.
- 049900 15 03ASTRKS-L.
- 050000 17 02ASTRKS-L.
- 050100 19 01ASTRK-L PIC X.
- 050200 19 FILLER PIC X.
- 050300 17 FILLER PIC X.
- 050400 15 FILLER PIC X.
- 050500 13 FILLER PIC X.
- 050600 11 FILLER PIC X.
- 050700 09 FILLER PIC X.
- 050800 07 FILLER PIC XX.
- 050900 05 FILLER PIC X.
- 051000 01 PAG-HDR1.
- 051100 03 FILLER PIC X(24) VALUE " PCN: AS OF ".
- 051200 03 DAY-PH1 PIC XX.
- 051300 03 FILLER PIC X VALUE SPACE.
- 051400 03 MON-PH1 PIC XXX.
- 051500 03 FILLER PIC X VALUE SPACE.
- 051600 03 YER-PH1 PIC XX.
- 051700 03 FILLER PIC X(09) VALUE SPACES.
- 051800 03 FILLER PIC X(48) VALUE "USDI- BUR OF LAND MGT ECOLOGIC
- 051900- "AL SITE INVENTORY".
- 052000 03 FILLER PIC X(29) VALUE SPACES.
- 052100 03 FILLER PIC X(6) VALUE "PAGE: ".
- 052200 03 PAG-CNT-PH1 PIC ZZ9.
- 052300 03 FILLER PIC XXXX VALUE SPACES.
- 052400 01 PAG-HDR2.
- 052500 03 FILLER PIC X(11) VALUE " STATE: ".
- 052600 03 ADST-NAM-PH2 PIC X(10).
- 052700 03 FILLER PIC X(17) VALUE " RES AREA: ".
- 052800 03 RA-CD-PH2 PIC XX.
- 052900 03 FILLER PIC X VALUE SPACE.
- 053000 03 RA-NAM-PH2 PIC X(13).
- 053100 03 FILLER PIC X(78) VALUE SPACES.
- 053200 01 PAG-HDR3.
- 053300 03 FILLER PIC X(11) VALUE " DIST: ".
- 053400 03 DIST-NAM-PH3 PIC X(12).
- 053500 03 FILLER PIC X(15) VALUE " PLNG UT: ".
- 053600 03 PLU-CD-PH3 PIC XX.
- 053700 03 FILLER PIC X VALUE SPACE.
- 053800 03 PLU-NAM-PH3 PIC X(15).
- 053900 03 FILLER PIC X(76) VALUE SPACES.
- 054000 01 PAG-HDR4.
- 054100 03 FILLER PIC X(50) VALUE SPACES.
- 054200 03 FILLER PIC X(33) VALUE "V1, V2, AND V3 EDIT ERROR LISTI
- 054300- "NG".
- 054400 03 FILLER PIC X(49) VALUE SPACES.
- 054500 01 PAG-HDR5.
- 054600 03 FILLER PIC X(17) VALUE SPACES.
- 054700 03 FILLER PIC X(97) VALUE "KEY COMMON DATA (1-44) IN ALL R
- 054800- "ECORDS. IF ERROR IN COMMON DATA (
- 054900- "9-24), KEY ALL RECORDS IN SWA/T.".
- 055000 03 FILLER PIC X(18) VALUE SPACES.
- 055100 01 PAG-HDR6.
- 055200 03 FILLER PIC X(17) VALUE SPACES.
- 055300 03 FILLER PIC X(99) VALUE "IF ERROR IN OTHER COMMON DATA,
- 055400- "KEY ALL OF THE RECORD - ELSE KEY AS
- 055500- "TERISK AND RED CORRECTION FIELDS.".
- 055600 03 FILLER PIC X(16) VALUE SPACES.
- 055700 01 TABL-AREA.
- 055800 03 MON-V PIC X(36) VALUE "JANFEBMARAPRMAYJUNJULAUGSEPOCT
- 055900- "NOVDEC".
- 056000 03 MON-T REDEFINES MON-V PIC XXX OCCURS 12 TIMES.
- 056100 03 SSF-VAL-RAT-V PIC X(14) VALUE "14141414151415".
- 056200 03 SSF-VAL-RAT-T REDEFINES SSF-VAL-RAT-V
- 056300 PIC XX OCCURS 7 TIMES.
- 056400 01 V11X.
- 056500 03 BATCH-NUM-V11X PIC XXXX.
- 056600 03 REC-TYP-T-FMT-CD-V11X.
- 056700 05 REC-TYP-V11X PIC XX.
- 056800 05 FMT-NUM-V11X PIC X.
- 056900 05 FMT-CD-V11X PIC X.
- 057000 03 ADST-CD-T-TRN-NUM-V11X.
- 057100 05 ADST-DIST-PLU-CDS-V11X PIC X(6).
- 057200 05 ALLOT-NUM-T-TRN-NUM-V11X PIC X(10).
- 057300 03 ACTN-CD-V11X PIC X.
- 057400 03 LIN-NUM-V11X PIC XXX.
- 057500 03 FILLER PIC X.
- 057600 03 SWA-BRWD-V11X.
- 057700 05 SWA-CD-BRWD-V11X PIC X.
- 057800 05 SWA-NUM-BRWD-V11X PIC XXX.
- 057900 05 TRN-NUM-BRWD-V11X PIC XX.
- 058000 03 RA-CD-V11X PIC XX.
- 058100 03 FILLER PIC X(7).
- 058200 03 V11AX.
- 058300 05 RNG-SITE-ID-V11AX PIC X(11).
- 058400 05 RNG-ECOL-COND-CLS-V11AX PIC X.
- 058500 05 VEG-SUB-TYP-V11AX PIC XXXX.
- 058600 05 SWA-PCT-V11AX PIC XXX.
- 058700 05 DATA-DAT-V11AX.
- 058800 07 DATA-YER-V11AX PIC XX.
- 058900 07 DATA-MON-V11AX PIC XX.
- 059000 07 DATA-DAY-V11AX PIC XX.
- 059100 05 RECER-INTLS-V11AX PIC XXX.
- 059200 05 PHOTO-ID-V11AX PIC X(16).
- 059300 05 CMPR-ID-V11AX.
- 059400 07 ADST-DIST-CDS-CMPR-V11AX.
- 059500 09 ADST-CD-CMPR-V11AX PIC XX.
- 059600 09 DIST-CD-CMPR-V11AX PIC XX.
- 059700 07 TWP-CMPR-V11AX.
- 059800 09 TWP-NUM-CMPR-V11AX PIC XXX.
- 059900 09 TWP-FRC-CMPR-V11AX PIC X.
- 060000 09 TWP-DIR-CMPR-V11AX PIC X.
- 060100 07 RNG-CMPR-V11AX.
- 060200 09 RNG-NUM-CMPR-V11AX PIC XXX.
- 060300 09 RNG-FRC-CMPR-V11AX PIC X.
- 060400 09 RNG-DIR-CMPR-V11AX PIC X.
- 060500 07 CONS-NUM-CMPR-V11AX PIC XX.
- 060600 05 FILLER PIC X(40).
- 060700 03 V12AX REDEFINES V11AX.
- 060800 05 TYP-GC-CD-V12AX PIC X.
- 060900 05 TYP-GC-HITS-V12AX PIC XXX.
- 061000 05 PLANT-CD-V12AX PIC X(7) OCCURS 4 TIMES.
- 061100 05 FILLER PIC X(68).
- 061200 03 V13AX REDEFINES V11AX.
- 061300 05 GRP1-V13AX.
- 061400 07 FILLER PIC X(39).
- 061500 07 PLANT-CDS-TYP-GC-HITS-V13AX PIC X(39).
- 061600 05 GRP2-V13AX REDEFINES GRP1-V13AX OCCURS 2 TIMES.
- 061700 07 PLANT-CD-V13AX PIC X(9) OCCURS 4 TIMES.
- 061800 07 TYP-GC-HITS-V13AX PIC XXX.
- 061900 05 FILLER PIC X(22).
- 062000 03 V14AX REDEFINES V11AX.
- 062100 05 SSF-VAL-RAT-V14AX PIC XX OCCURS 7 TIMES.
- 062200 05 FILLER PIC X(86).
- 062300 03 V21AX REDEFINES V11AX.
- 062400 05 PLOT-SIZ-V21AX PIC X.
- 062500 05 PLOT-NUM-V21AX PIC XX.
- 062600 05 PLOT-NUM-V21AR REDEFINES PLOT-NUM-V21AX PIC 99.
- 062700 05 PLANT-CD-V21AX PIC X(7).
- 062800 05 AGE-CLS-PLANT-V21AX PIC X.
- 062900 05 FORM-CLS-PLANT-V21AX PIC X.
- 063000 05 PHNO-STG-V21AX PIC X.
- 063100 05 CLS-PLANT-AVAIL-V21AX PIC X.
- 063200 05 CLS-PLANT-UTIL-V21AX PIC X.
- 063300 05 AVG-HGT-PLANT-V21AX.
- 063400 07 AVG-HGT-PLANT-INGR-V21AX PIC XXX.
- 063500 07 AVG-HGT-PLANT-FRC-V21AX PIC XX.
- 063600 05 CHARZD-NUM-V21AX PIC XXX.
- 063700 05 AVG-LDR-LGT-V21AX.
- 063800 07 AVG-LDR-LGT-INGR-V21AX PIC XXX.
- 063900 07 AVG-LDR-LGT-FRC-V21AX PIC XX.
- 064000 05 AVG-CRN-DIA-V21AX.
- 064100 07 AVG-CRN-DIA-INGR-V21AX PIC XXX.
- 064200 07 AVG-CRN-DIA-FRC-V21AX PIC XX.
- 064300 05 CHARZD-NOT-NUM-V21AX PIC XXX.
- 064400 05 MAST-CROPS-CD-V21AX PIC X.
- 064500 05 FILLER PIC X(63).
- 064600 03 V3XBX REDEFINES V11AX.
- 064700 05 PLOT-TOT-NUM-V3XBX PIC XX.
- 064800 05 PLOT-SIZ-EST-V3XBX.
- 064900 07 PLOT-SIZ-EST-INGR-V3XBX PIC X(5).
- 065000 07 PLOT-SIZ-EST-FRC-V3XBX PIC XX.
- 065100 05 PLANT-CD-V3XBX PIC X(7).
- 065200 05 HGT-CLS-CD-V3XBX PIC X.
- 065300 05 GRP-V3XBX OCCURS 10 TIMES.
- 065400 07 CLS-PLANT-AVAIL-V3XBX PIC X.
- 065500 07 PHNO-STG-V3XBX PIC X.
- 065600 07 CLS-PLANT-UTIL-V3XBX PIC X.
- 065700 07 HRBG-PROD-WGT-V3XBX PIC XXXX.
- 065800 05 FILLER PIC X(13).
- 065900 01 V11Z.
- 066000 03 BATCH-NUM-V11Z PIC 9999.
- 066100 03 REC-TYP-V11Z PIC XX.
- 066200 03 FMT-NUM-V11Z PIC 9.
- 066300 03 FMT-CD-V11Z PIC X.
- 066400 03 ADST-CD-V11Z PIC XX.
- 066500 03 DIST-CD-V11Z PIC 99.
- 066600 03 PLU-CD-V11Z PIC 99.
- 066700 03 ALLOT-NUM-V11Z PIC 9999.
- 066800 03 SWA-V11Z.
- 066900 05 SWA-CD-V11Z PIC X.
- 067000 05 SWA-NUM-V11Z PIC 999.
- 067100 03 TRN-NUM-V11Z PIC 99.
- 067200 03 ACTN-CD-V11Z PIC X.
- 067300 03 LIN-NUM-V11Z PIC 999.
- 067400 03 FILLER PIC X.
- 067500 03 SWA-BRWD-V11Z.
- 067600 05 SWA-CD-BRWD-V11Z PIC X.
- 067700 05 SWA-NUM-BRWD-V11Z PIC XXX.
- 067800 05 TRN-NUM-BRWD-V11Z PIC XX.
- 067900 03 RA-CD-V11Z PIC XX.
- 068000 03 FILLER PIC X(7).
- 068100 03 V11AZ.
- 068200 05 RNG-SITE-ID-V11AZ PIC X(11).
- 068300 05 RNG-ECOL-COND-CLS-V11AZ PIC X.
- 068400 05 VEG-SUB-TYP-V11AZ PIC 9999.
- 068500 05 SWA-PCT-V11AZ PIC 999.
- 068600 05 DATA-DAT-V11AZ PIC X(6).
- 068700 05 RECER-INTLS-V11AZ PIC XXX.
- 068800 05 PHOTO-ID-V11AZ PIC X(16).
- 068900 05 CMPR-ID-V11AZ.
- 069000 07 ADST-CD-CMPR-V11AZ PIC XX.
- 069100 07 DIST-CD-CMPR-V11AZ PIC 99.
- 069200 07 TWP-CMPR-V11AZ.
- 069300 09 TWP-NUM-CMPR-V11AZ PIC 999.
- 069400 09 TWP-FRC-CMPR-V11AZ PIC 9.
- 069500 09 TWP-DIR-CMPR-V11AZ PIC X.
- 069600 07 RNG-CMPR-V11AZ.
- 069700 09 RNG-NUM-CMPR-V11AZ PIC 999.
- 069800 09 RNG-FRC-CMPR-V11AZ PIC 9.
- 069900 09 RNG-DIR-CMPR-V11AZ PIC X.
- 070000 07 CONS-NUM-CMPR-V11AZ PIC 99.
- 070100 05 FILLER PIC X(35).
- 070200 03 V12AZ REDEFINES V11AZ.
- 070300 05 TYP-GC-CD-V12AZ PIC X.
- 070400 05 TYP-GC-HITS-V12AZ PIC 999.
- 070500 05 GRP1-V12AZ.
- 070600 07 GRP2-V12AZ OCCURS 4 TIMES.
- 070700 09 PLANT-TYP-V12AZ PIC X.
- 070800 09 PLANT-CD-V12AZ PIC X(7).
- 070900 05 FILLER PIC X(59).
- 071000 03 V13AZ REDEFINES V11AZ.
- 071100 05 GRP-V13AZ OCCURS 2 TIMES.
- 071200 07 PLANT-CD-V13AZ PIC X(9) OCCURS 4 TIMES.
- 071300 07 TYP-GC-HITS-V13AZ PIC 999.
- 071400 05 FILLER PIC X(17).
- 071500 03 V14AZ REDEFINES V11AZ.
- 071600 05 SSF-VAL-RAT-V14AZ PIC XX OCCURS 7 TIMES.
- 071700 05 SSF-VAL-AVG-V14AZ PIC XXX.
- 071800 05 FILLER PIC X(78).
- 071900 03 V21AZ REDEFINES V11AZ.
- 072000 05 PLOT-SIZ-V21AZ PIC 9.
- 072100 05 PLOT-NUM-V21AZ PIC 99.
- 072200 05 PLANT-CD-V21AZ PIC X(7).
- 072300 05 AGE-CLS-PLANT-V21AZ PIC X.
- 072400 05 FORM-CLS-PLANT-V21AZ PIC 9.
- 072500 05 PHNO-STG-V21AZ PIC 9.
- 072600 05 CLS-PLANT-AVAIL-V21AZ PIC X.
- 072700 05 CLS-PLANT-UTIL-V21AZ PIC 9.
- 072800 05 GRP-V21AZ.
- 072900 07 AVG-HGT-PLANT-V21AZ PIC 999V9.
- 073000 07 CHARZD-NUM-V21AZ PIC 999.
- 073100 07 AVG-LDR-LGT-V21AZ PIC 99V9.
- 073200 07 FILLER PIC X.
- 073300 07 AVG-CRN-DIA-V21AZ PIC 99V9.
- 073400 07 FILLER PIC X.
- 073500 07 CHARZD-NOT-NUM-V21AZ PIC 999.
- 073600 07 MAST-CROPS-CD-V21AZ PIC X.
- 073700 07 FILLER PIC XXX.
- 073800 05 FILLER PIC X(57).
- 073900 05 PLANT-TYP-V21AZ PIC X.
- 074000 03 V3XBZ REDEFINES V11AZ.
- 074100 05 PLOT-TOT-NUM-V3XBZ PIC 99.
- 074200 05 PLOT-SIZ-EST-V3XBZ PIC 999V99.
- 074300 05 PLOT-SIZ-FIL-V3XBZ PIC XX.
- 074400 05 PLANT-CD-V3XBZ PIC X(7).
- 074500 05 HGT-CLS-CD-V3XBZ PIC 9.
- 074600 05 GRP-V3XBZ OCCURS 10 TIMES.
- 074700 07 CLS-PLANT-AVAIL-V3XBZ PIC X.
- 074800 07 PHNO-STG-T-PROD-WGT-V3XBZ.
- 074900 09 PHNO-STG-V3XBZ PIC 9.
- 075000 09 CLS-PLANT-UTIL-V3XBZ PIC 9.
- 075100 09 HRBG-PROD-WGT-V3XBZ PIC 9999.
- 075200 05 FILLER PIC X(7).
- 075300 05 PLANT-TYP-V3XBZ PIC X.
- 075400 03 FILLER PIC X(5).
- 075500 PROCEDURE DIVISION.
- 075600 START-PARA.
- 075700 MOVE SPACE TO PLT-TABLE.
- 075800 MOVE ZERO TO PLT-TABLE-2.
- 075900 ACCEPT DAT-H FROM DATE. MOVE DAY-H TO DAY-PH1.
- 076000 MOVE MON-T (MON-H) TO MON-PH1. MOVE YER-H TO YER-PH1.
- 076100 OPEN INPUT FIL-I1,
- 076200 OUTPUT FIL-D1, FIL-P1. READY DIC-DE.
- 076300 0100.
- 076400 READ FIL-I1 AT END
- 076500 GO TO 9950-WRAP-UP.
- 076600 IF SDP-I1 = "CO0710"
- 076700 MOVE "CO0709" TO SDP-I1.
- 076800 IF SDP-I1 = "NM0303"
- 076900 MOVE "NM0305" TO SDP-I1.
- 077000 IF SDP-I1 = "WY0425"
- 077100 MOVE "WY0435" TO SDP-I1.
- 077200 IF SDP-I1 = "WY0324" OR "WY0335"
- 077300 MOVE "WY0323" TO SDP-I1.
- 077400 ADD 1 TO IN-CNTR. MOVE REC-I1 TO V11X, V11Z.
- 077500 IF ADST-CD-T-TRN-NUM-V11H = ADST-CD-T-TRN-NUM-V11X
- 077600 GO TO 0600.
- 077700 MOVE ZERO TO KEY-FLG. MOVE 1 TO RITE-HDR-FLG, RITE-KEY-FLG.
- 077800 IF ADST-DIST-PLU-CDS-V11H = ADST-DIST-PLU-CDS-V11X
- 077900 GO TO 0500. MOVE ZERO TO PAG-CNT.
- 078000 MOVE 0003 TO DE-NO-8801-DEC. MOVE 48 TO LIN-CHK.
- 078100 MOVE SPACES TO KEY-LIN1B1, RA-CD-PH2.
- 078200 MOVE "UNKNOWN " TO ADST-NAM-PH2, DIST-NAM-PH3,
- 078300 RA-NAM-PH2, PLU-NAM-PH3.
- 078400 MOVE ADST-DIST-PLU-CDS-V11X TO ADST-DIST-PLU-CDS-V11H.
- 078500 MOVE PLU-CD-V11H TO PLU-CD-H, PLU-CD-KL1A, PLU-CD-PH3.
- 078600 MOVE DIST-CD-V11H TO DIST-CD-H, DIST-CD-KL1A.
- 078700 MOVE ADST-CD-V11H TO ADST-CD-H, ADST-CD-KL1A, DE-CD-8822-DEC.
- 078800 FIND ANY CODE-DEC.
- 078900 IF DB-STATUS NOT = ZERO MOVE 02ASTRKS-L TO
- 079000 ADST-CD-KL1B, DIST-CD-KL1B, PLU-CD-KL1B
- 079100 MOVE 1 TO KEY-FLG GO TO 0500.
- 079200 GET CODE-DEC.
- 079300 MOVE DE-CD-NAM-8823-DEC TO DE-CD-NAM-8823-DEC-H.
- 079400 MOVE ST-NAM-H TO ADST-NAM-PH2.
- 079500 MOVE ADST-DIST-CDS-H TO DE-CD-8822-DEC.
- 079600 FIND ANY CODE-DEC.
- 079700 IF DB-STATUS NOT = ZERO MOVE 02ASTRKS-L TO
- 079800 DIST-CD-KL1B, PLU-CD-KL1B
- 079900 MOVE 1 TO KEY-FLG GO TO 0500.
- 080000 GET CODE-DEC. FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
- 080100 IF DB-STATUS NOT = ZERO MOVE 02ASTRKS-L TO
- 080200 DIST-CD-KL1B, PLU-CD-KL1B
- 080300 MOVE 1 TO KEY-FLG GO TO 0500.
- 080400 GET CODE-EXPL-DECE.
- 080500 MOVE DE-CD-EXPLN-8827-DECE TO DE-CD-EXPLN-8827-DECE-H.
- 080600 MOVE DIST-NAM-H TO DIST-NAM-PH3. MOVE 4 TO RA-CD-C1-H.
- 080700 0300.
- 080800 MOVE ADST-DIST-RA-PLU-CDS-H TO DE-CD-8822-DEC.
- 080900 FIND ANY CODE-DEC.
- 081000 IF DB-STATUS NOT = ZERO GO TO 0400.
- 081100 GET CODE-DEC. FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
- 081200 IF DB-STATUS = ZERO GET CODE-EXPL-DECE
- 081300 MOVE DE-CD-EXPLN-8827-DECE TO DE-CD-EXPLN-8827-DECE-H
- 081400 MOVE RA-CD-H TO RA-CD-PH2 MOVE RA-NAM-H TO RA-NAM-PH2
- 081500 MOVE PLU-NAM-H TO PLU-NAM-PH3 GO TO 0500.
- 081600 0400.
- 081700 IF RA-CD-C1-H < 8 ADD 1 TO RA-CD-C1-H GO TO 0300.
- 081800* MOVE 02ASTRKS-L TO PLU-CD-KL1B. MOVE 1 TO KEY-FLG.
- 081900 ADD 1 TO CNT-BAD-PU.
- 082000 0500.
- 082100 MOVE SPACES TO KEY-LIN1B2.
- 082200 MOVE ALLOT-NUM-T-TRN-NUM-V11X TO ALLOT-NUM-T-TRN-NUM-V11H.
- 082300 MOVE ALLOT-NUM-V11H TO ALLOT-NUM-KL1A.
- 082400 MOVE SWA-V11H TO SWA-KL1A.
- 082500 MOVE TRN-NUM-V11H TO TRN-NUM-KL1A.
- 082600 IF ALLOT-NUM-V11H NOT NUMERIC
- 082700* MOVE 04ASTRKS-L TO ALLOT-NUM-KL1B MOVE 1 TO KEY-FLG.
- 082800 ADD 1 TO CNT-BAD-ALOT.
- 082900 IF SWA-CD-V11H NOT ALPHABETIC OR SWA-CD-V11H = SPACE
- 083000 MOVE 01ASTRK-L TO SWA-CD-KL1B MOVE 1 TO KEY-FLG.
- 083100 IF SWA-NUM-V11H NOT NUMERIC
- 083200 MOVE 03ASTRKS-L TO SWA-NUM-KL1B MOVE 1 TO KEY-FLG.
- 083300 IF TRN-NUM-V11H NOT NUMERIC
- 083400 MOVE 02ASTRKS-L TO TRN-NUM-KL1B MOVE 1 TO KEY-FLG.
- 083500 0600.
- 083600 MOVE RA-CD-H TO RA-CD-V11X, RA-CD-V11Z.
- 083700 MOVE KEY-FLG TO DATA-FLG.
- 083800 IF ACTN-CD-V11X = "A" GO TO 0700.
- 083900 IF ACTN-CD-V11X = "R"
- 084000 MOVE ZERO TO LIN-NUM-V11Z GO TO 0800.
- 084100 IF LIN-NUM-V11X NOT NUMERIC OR LIN-NUM-V11X = ZERO
- 084200 MOVE 03ASTRKS-L TO LIN-NUM-DL1B
- 084300 MOVE 1 TO DATA-FLG. GO TO 0800.
- 084400 0700.
- 084500 MOVE REC-TYP-T-FMT-CD-V11X TO REC-TYP-T-FMT-CD-V11H.
- 084600 MOVE ACTN-CD-V11X TO ACTN-CD-V11H.
- 084700 IF ADST-CD-T-ACTN-CD-V11H NOT = ADST-CD-T-ACTN-CD-V11X-H
- 084800 MOVE ADST-CD-T-ACTN-CD-V11H TO ADST-CD-T-ACTN-CD-V11X-H
- 084900 MOVE ZERO TO LIN-NUM-H.
- 085000 ADD 1 TO LIN-NUM-H.
- 085100 0800.
- 085200 IF (CNT-BAD-TYPE > 25) OR (CNT-BAD-FORM > 25) OR
- 085300 (CNT-BAD-CODE > 25)
- 085400 DISPLAY " "
- 085500 DISPLAY "ABORT ABORT ABORT ABORT ABORT ABORT ABORT"
- 085600 DISPLAY " "
- 085700 GO TO 9950-WRAP-UP.
- 085800 IF REC-TYP-V11X = "V2" GO TO 5000.
- 085900 IF REC-TYP-V11X = "V3" GO TO 6000.
- 086000 IF REC-TYP-V11X NOT = "V1"
- 086100 ADD 1 TO CNT-BAD-TYPE
- 086200 DISPLAY "BAD REC TYPE= " V11X
- 086300 GO TO 0100.
- 086400 ADD 1 TO CNT-V1.
- 086500 IF FMT-NUM-V11X = "2" GO TO 2000.
- 086600 IF FMT-NUM-V11X = "3" MOVE 1 TO SS1A, SS1B GO TO 3000.
- 086700 IF FMT-NUM-V11X = "4" MOVE 1 TO SS1A GO TO 4000.
- 086800 IF FMT-NUM-V11X NOT = "1"
- 086900 ADD 1 TO CNT-BAD-FORM
- 087000 DISPLAY "BAD REC FORM= " V11X
- 087100 GO TO 0100.
- 087200 IF SWA-BRWD-V11X = SPACES GO TO 0900.
- 087300 IF SWA-CD-BRWD-V11X NOT ALPHABETIC
- 087400 OR SWA-CD-BRWD-V11X = SPACE
- 087500 MOVE 01ASTRK-L TO SWA-CD-BRWD-DL1B11
- 087600 MOVE 1 TO DATA-FLG.
- 087700 IF SWA-NUM-BRWD-V11X NOT NUMERIC
- 087800 MOVE 03ASTRKS-L TO SWA-NUM-BRWD-DL1B11
- 087900 MOVE 1 TO DATA-FLG.
- 088000 IF TRN-NUM-BRWD-V11X NOT NUMERIC
- 088100 MOVE 02ASTRKS-L TO TRN-NUM-BRWD-DL1B11
- 088200 MOVE 1 TO DATA-FLG.
- 088300 IF DATA-FLG ZERO MOVE SPACES TO V11AZ GO TO 7000.
- 088400 IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-V11X
- 088500 MOVE COL-HDRA11 TO COL-HDR2A1
- 088600 MOVE COL-HDRB11 TO COL-HDR2B1
- 088700 MOVE COL-HDRC11 TO COL-HDR2C1
- 088800 MOVE 1 TO RITE-HDR-FLG.
- 088900 MOVE SWA-BRWD-V11X TO SWA-BRWD-DL1A11. GO TO 7100.
- 089000 0900.
- 089100 IF DATA-YER-V11AX NOT NUMERIC
- 089200 MOVE 02ASTRKS-L TO DATA-YER-DL1B11
- 089300 MOVE 1 TO DATA-FLG.
- 089400 IF DATA-MON-V11AX NOT NUMERIC
- 089500 OR DATA-MON-V11AX < "01" OR > "12"
- 089600 MOVE 02ASTRKS-L TO DATA-MON-DL1B11
- 089700 MOVE 1 TO DATA-FLG.
- 089800 IF DATA-DAY-V11AX NOT NUMERIC
- 089900 OR DATA-DAY-V11AX < "01" OR > "31"
- 090000 MOVE 02ASTRKS-L TO DATA-DAY-DL1B11
- 090100 MOVE 1 TO DATA-FLG.
- 090200 IF DAT-H NOT > DATA-DAT-V11AX
- 090300 MOVE 06ASTRKS-L TO DATA-DAT-DL1B11
- 090400 MOVE 1 TO DATA-FLG.
- 090500 IF ADST-DIST-CDS-CMPR-V11AX = SPACES GO TO 1400.
- 090600 MOVE 0003 TO DE-NO-8801-DEC.
- 090700 MOVE ADST-CD-CMPR-V11AX TO DE-CD-8822-DEC.
- 090800 FIND ANY CODE-DEC.
- 090900 IF DB-STATUS NOT = ZERO
- 091000 MOVE 02ASTRKS-L TO ADST-CD-CMPR-DL1B11
- 091100 MOVE 1 TO DATA-FLG.
- 091200 MOVE ADST-DIST-CDS-CMPR-V11AX TO DE-CD-8822-DEC.
- 091300 FIND ANY CODE-DEC.
- 091400 IF DB-STATUS NOT = ZERO
- 091500 MOVE 02ASTRKS-L TO DIST-CD-CMPR-DL1B11
- 091600 MOVE 1 TO DATA-FLG.
- 091700 1400.
- 091800 IF CONS-NUM-CMPR-V11AX = SPACES
- 091900 MOVE ZERO TO CONS-NUM-CMPR-V11AZ
- 092000 ELSE IF CONS-NUM-CMPR-V11AX NOT NUMERIC
- 092100 OR CONS-NUM-CMPR-V11AX NOT > ZERO
- 092200 MOVE 02ASTRKS-L TO CONS-NUM-CMPR-DL1B11
- 092300 MOVE 1 TO DATA-FLG.
- 092400 IF DATA-FLG NOT ZERO GO TO 1500.
- 092500 IF VEG-SUB-TYP-V11AX = SPACES
- 092600 MOVE ZERO TO VEG-SUB-TYP-V11AZ.
- 092700 MOVE DATA-DAT-V11AX TO DATA-DAT-V11AZ.
- 092800 IF DIST-CD-CMPR-V11AX = SPACES
- 092900 MOVE ZERO TO DIST-CD-CMPR-V11AZ.
- 093000 IF TWP-NUM-CMPR-V11AX = SPACES
- 093100 MOVE ZERO TO TWP-NUM-CMPR-V11AZ.
- 093200 IF TWP-FRC-CMPR-V11AX = SPACE
- 093300 MOVE ZERO TO TWP-FRC-CMPR-V11AZ.
- 093400 IF RNG-NUM-CMPR-V11AX = SPACES
- 093500 MOVE ZERO TO RNG-NUM-CMPR-V11AZ.
- 093600 IF RNG-FRC-CMPR-V11AX = SPACE
- 093700 MOVE ZERO TO RNG-FRC-CMPR-V11AZ. GO TO 7000.
- 093800 1500.
- 093900 IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-V11X
- 094000 MOVE COL-HDRA11 TO COL-HDR2A1
- 094100 MOVE COL-HDRB11 TO COL-HDR2B1
- 094200 MOVE COL-HDRC11 TO COL-HDR2C1
- 094300 MOVE 1 TO RITE-HDR-FLG.
- 094400 MOVE RNG-SITE-ID-V11AX TO RNG-SITE-ID-DL1A11.
- 094500 MOVE RNG-ECOL-COND-CLS-V11AX TO RNG-ECOL-COND-CLS-DL1A11.
- 094600 MOVE VEG-SUB-TYP-V11AX TO VEG-SUB-TYP-DL1A11.
- 094700 MOVE SWA-PCT-V11AX TO SWA-PCT-DL1A11.
- 094800 MOVE DATA-DAT-V11AX TO DATA-DAT-DL1A11.
- 094900 MOVE RECER-INTLS-V11AX TO RECER-INTLS-DL1A11.
- 095000 MOVE PHOTO-ID-V11AX TO PHOTO-ID-DL1A11.
- 095100 MOVE ADST-CD-CMPR-V11AX TO ADST-CD-CMPR-DL1A11.
- 095200 MOVE DIST-CD-CMPR-V11AX TO DIST-CD-CMPR-DL1A11.
- 095300 MOVE TWP-CMPR-V11AX TO TWP-CMPR-DL1A11.
- 095400 MOVE RNG-CMPR-V11AX TO RNG-CMPR-DL1A11.
- 095500 MOVE CONS-NUM-CMPR-V11AX TO CONS-NUM-CMPR-DL1A11.
- 095600 GO TO 7100.
- 095700 2000.
- 095800 MOVE SPACES TO GRP1-V12AZ. MOVE 1 TO SS1A.
- 095900 IF TYP-GC-HITS-V12AX = SPACES OR ZERO
- 096000 MOVE ZERO TO TYP-GC-HITS-V12AZ GO TO 2200.
- 096100 IF TYP-GC-CD-V12AX NOT =
- 096200 "B" AND "C" AND "G" AND "N" AND "P" AND "R" AND "S"
- 096300 MOVE 01ASTRK-L TO TYP-GC-CD-DL1B12
- 096400 MOVE 1 TO DATA-FLG.
- 096500 IF TYP-GC-HITS-V12AX NOT NUMERIC
- 096600 MOVE 03ASTRKS-L TO TYP-GC-HITS-DL1B12
- 096700 MOVE 1 TO DATA-FLG. GO TO 2200.
- 096800 2100.
- 096900 IF TYP-GC-CD-V12AX NOT = SPACE AND
- 097000 "B" AND "C" AND "G" AND "N" AND "P" AND "R" AND "S"
- 097100 MOVE 01ASTRK-L TO TYP-GC-CD-DL1B12
- 097200 MOVE 1 TO DATA-FLG.
- 097300 2200.
- 097400 MOVE PLANT-CD-V12AX (SS1A) TO PLT-HLD.
- 097500 PERFORM 9900-PLT-CNV.
- 097600 MOVE PLT-HLD TO PLANT-CD-V12AX (SS1A).
- 097700 MOVE PLANT-CD-V12AX (SS1A) TO DE-CD-8822-DEC.
- 097800 IF DE-CD-8822-DEC = SPACES GO TO 2400.
- 097900 PERFORM 9200. IF PLANT-CD-FLG NOT ZERO
- 098000 MOVE 07ASTRKS-L TO PLANT-CD-DL1B12 (SS1A)
- 098100 MOVE 1 TO DATA-FLG
- 098200 ELSE MOVE PLANT-TYP-H TO PLANT-TYP-V12AZ (SS1A)
- 098300 MOVE PLANT-CD-H TO PLANT-CD-V12AZ (SS1A).
- 098400 2400.
- 098500 IF SS1A < 4 ADD 1 TO SS1A GO TO 2200.
- 098600 IF DATA-FLG ZERO GO TO 7000.
- 098700 IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-V11X
- 098800 MOVE COL-HDRA12 TO COL-HDR2A1
- 098900 MOVE COL-HDRB12 TO COL-HDR2B1
- 099000 MOVE COL-HDRC12 TO COL-HDR2C1
- 099100 MOVE 1 TO RITE-HDR-FLG.
- 099200 MOVE TYP-GC-CD-V12AX TO TYP-GC-CD-DL1A12.
- 099300 MOVE TYP-GC-HITS-V12AX TO TYP-GC-HITS-DL1A12.
- 099400 MOVE 1 TO SS1A.
- 099500 2800.
- 099600 MOVE PLANT-CD-V12AX (SS1A) TO PLANT-CD-DL1A12 (SS1A).
- 099700 IF SS1A < 4 ADD 1 TO SS1A GO TO 2800.
- 099800 GO TO 7100.
- 099900 3000.
- 100000 MOVE PLANT-CD-V13AX (SS1A, SS1B) TO PLT-HLD.
- 100100 PERFORM 9900-PLT-CNV.
- 100200 MOVE PLT-HLD TO PLANT-CD-V13AX (SS1A, SS1B).
- 100300 MOVE PLANT-CD-V13AX (SS1A, SS1B) TO PLANT-CD-V13AX-H.
- 100400 IF PLANT-CD-V13AX-H = SPACES GO TO 3800.
- 100500 IF PLANT-CD-LST-8C-V13AX-H NOT = SPACES GO TO 3300.
- 100600 IF PLANT-CD-C1-V13AX-H NOT = "B" AND "C" AND "G" AND "L"
- 100700 AND "M" AND "N" AND "P" AND "R" AND "S"
- 100800 MOVE 09ASTRKS-L TO PLANT-CD-DL1B13 (SS1A, SS1B)
- 100900 MOVE 1 TO DATA-FLG. GO TO 3800.
- 101000 3300.
- 101100 MOVE PLANT-CD-1ST-8C-V13AX-H TO DE-CD-8822-DEC.
- 101200 PERFORM 9200. IF PLANT-CD-FLG ZERO GO TO 3800.
- 101300 MOVE SPACES TO PLANT-CD-V13AZ-H.
- 101400 MOVE 1 TO SS1C, SS1D.
- 101500 3600.
- 101600 MOVE 1C-PLANT-CD-V13AX-H (SS1C) TO 1C-PLANT-CD-H.
- 101700 IF 1C-PLANT-CD-H = "(" OR ")" MOVE SPACE TO 1C-PLANT-CD-H
- 101800 MOVE "*" TO LEV-TRN-HIT-V13AZ-H.
- 101900 IF 1C-PLANT-CD-H NOT = SPACE MOVE 1C-PLANT-CD-H
- 102000 TO 1C-PLANT-CD-V13AZ-H (SS1D) ADD 1 TO SS1D.
- 102100 IF SS1C < 9 ADD 1 TO SS1C GO TO 3600.
- 102200 IF PLANT-CD-C2T7-V13AZ-H NOT = SPACES GO TO 3700.
- 102300 IF PLANT-CD-C1-V13AZ-H = "B" OR "C" OR "G" OR "L" OR "M"
- 102400 OR "N" OR "P" OR "R" OR "S"
- 102500 MOVE PLANT-CD-V13AZ-H TO PLANT-CD-V13AZ (SS1A, SS1B)
- 102600 GO TO 3800.
- 102700 MOVE 09ASTRKS-L TO PLANT-CD-DL1B13 (SS1A, SS1B).
- 102800 MOVE 1 TO DATA-FLG. GO TO 3800.
- 102900 3700.
- 103000 MOVE PLANT-CD-1ST-7C-V13AZ-H TO DE-CD-8822-DEC.
- 103100 PERFORM 9200. IF PLANT-CD-FLG NOT ZERO
- 103200 MOVE 09ASTRKS-L TO PLANT-CD-DL1B13 (SS1A, SS1B)
- 103300 MOVE 1 TO DATA-FLG
- 103400 ELSE MOVE PLANT-CD-V13AZ-H TO PLANT-CD-V13AZ (SS1A, SS1B).
- 103500 3800.
- 103600 IF SS1B < 4 ADD 1 TO SS1B GO TO 3000.
- 103700 MOVE TYP-GC-HITS-V13AX (SS1A) TO TYP-GC-HITS-V13AX-H.
- 103800 IF TYP-GC-HITS-V13AX-H NOT NUMERIC
- 103900 OR TYP-GC-HITS-V13AX-H NOT > ZERO
- 104000 MOVE 03ASTRKS-L TO TYP-GC-HITS-DL1B13 (SS1A)
- 104100 MOVE 1 TO DATA-FLG.
- 104200 IF SS1A < 2 AND PLANT-CDS-TYP-GC-HITS-V13AX NOT = SPACES
- 104300 MOVE 2 TO SS1A MOVE 1 TO SS1B GO TO 3000.
- 104400 IF DATA-FLG NOT ZERO GO TO 3850.
- 104500 IF TYP-GC-HITS-V13AX (SS1A) = SPACES
- 104600 MOVE ZERO TO TYP-GC-HITS-V13AZ (SS1A). GO TO 7000.
- 104700 3850.
- 104800 IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-V11X
- 104900 MOVE COL-HDRA13 TO COL-HDR2A1
- 105000 MOVE COL-HDRB13 TO COL-HDR2B1
- 105100 MOVE COL-HDRC13 TO COL-HDR2C1
- 105200 MOVE 1 TO RITE-HDR-FLG.
- 105300 MOVE 1 TO SS1A, SS1B.
- 105400 3900.
- 105500 MOVE PLANT-CD-V13AX (SS1A, SS1B)
- 105600 TO PLANT-CD-DL1A13 (SS1A, SS1B).
- 105700 IF SS1B < 4 ADD 1 TO SS1B GO TO 3900.
- 105800 MOVE TYP-GC-HITS-V13AX (SS1A) TO TYP-GC-HITS-DL1A13 (SS1A).
- 105900 IF SS1A < 2 AND PLANT-CDS-TYP-GC-HITS-V13AX NOT = SPACES
- 106000 MOVE 2 TO SS1A MOVE 1 TO SS1B GO TO 3900.
- 106100 GO TO 7100.
- 106200 4000.
- 106300 MOVE SSF-VAL-RAT-V14AX (SS1A) TO SSF-VAL-RAT-V14AX-H.
- 106400 IF SSF-VAL-RAT-V14AX-H = SPACES
- 106500 MOVE "99" TO SSF-VAL-RAT-V14AX (SS1A)
- 106600 SSF-VAL-RAT-V14AZ (SS1A) GO TO 4500.
- 106700 IF SSF-VAL-RAT-V14AX-H = "NA" OR "99"
- 106800 OR SSF-VAL-RAT-V14AX-H NUMERIC
- 106900 AND SSF-VAL-RAT-V14AX-H NOT > SSF-VAL-RAT-T (SS1A)
- 107000 GO TO 4500.
- 107100 MOVE 02ASTRKS-L TO SSF-VAL-RAT-DL1B14 (SS1A).
- 107200 MOVE 1 TO DATA-FLG.
- 107300 4500.
- 107400 IF SS1A < 7 ADD 1 TO SS1A GO TO 4000.
- 107500 IF DATA-FLG ZERO
- 107600 MOVE SPACES TO SSF-VAL-AVG-V14AZ GO TO 7000.
- 107700 IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-V11X
- 107800 MOVE COL-HDRA14 TO COL-HDR2A1
- 107900 MOVE COL-HDRB14 TO COL-HDR2B1
- 108000 MOVE COL-HDRC14 TO COL-HDR2C1
- 108100 MOVE 1 TO RITE-HDR-FLG.
- 108200 MOVE 1 TO SS1A.
- 108300 4800.
- 108400 MOVE SSF-VAL-RAT-V14AX (SS1A) TO SSF-VAL-RAT-DL1A14 (SS1A).
- 108500 IF SS1A < 7 ADD 1 TO SS1A GO TO 4800.
- 108600 GO TO 7100.
- 108700 5000.
- 108800 ADD 1 TO CNT-V2.
- 108900 MOVE PLANT-CD-V21AX TO PLT-HLD.
- 109000 PERFORM 9900-PLT-CNV.
- 109100 MOVE PLT-HLD TO PLANT-CD-V21AX .
- 109200 IF PLANT-CD-V21AX = "BARREN "
- 109300 MOVE SPACES TO V21AZ MOVE ZERO TO PLOT-SIZ-V21AZ,
- 109400 FORM-CLS-PLANT-V21AZ, PHNO-STG-V21AZ,
- 109500 CLS-PLANT-UTIL-V21AZ, AVG-HGT-PLANT-V21AZ,
- 109600 AVG-LDR-LGT-V21AZ, AVG-CRN-DIA-V21AZ,
- 109700 CHARZD-NOT-NUM-V21AZ
- 109800 MOVE PLOT-NUM-V21AR TO PLOT-NUM-V21AZ
- 109900 MOVE PLANT-CD-V21AX TO PLANT-CD-V21AZ
- 110000 MOVE 001 TO CHARZD-NUM-V21AZ GO TO 7000.
- 110100 IF PLOT-SIZ-V21AX NOT = "1" AND "2"
- 110200 MOVE 01ASTRK-L TO PLOT-SIZ-DL1B21
- 110300 MOVE 1 TO DATA-FLG.
- 110400 IF PLOT-NUM-V21AX NOT NUMERIC
- 110500 OR PLOT-NUM-V21AX < "01" OR > "40"
- 110600 MOVE 02ASTRKS-L TO PLOT-NUM-DL1B21
- 110700 MOVE 1 TO DATA-FLG.
- 110800 MOVE PLANT-CD-V21AX TO DE-CD-8822-DEC.
- 110900 PERFORM 9200. IF PLANT-CD-FLG NOT ZERO
- 111000 MOVE 07ASTRKS-L TO PLANT-CD-DL1B21
- 111100 MOVE 1 TO DATA-FLG
- 111200 ELSE MOVE PLANT-TYP-H TO PLANT-TYP-V21AZ.
- 111300 5100.
- 111400 IF FORM-CLS-PLANT-V21AX NOT = "5" GO TO 5150.
- 111500 IF AGE-CLS-PLANT-V21AX NOT = SPACE
- 111600 MOVE 01ASTRK-L TO AGE-CLS-PLANT-DL1B21
- 111700 MOVE 1 TO DATA-FLG.
- 111800 IF PHNO-STG-V21AX NOT = SPACE
- 111900 MOVE 01ASTRK-L TO PHNO-STG-DL1B21
- 112000 MOVE 1 TO DATA-FLG.
- 112100 IF CLS-PLANT-AVAIL-V21AX NOT = SPACE
- 112200 MOVE 01ASTRK-L TO CLS-PLANT-AVAIL-DL1B21
- 112300 MOVE 1 TO DATA-FLG.
- 112400 IF CLS-PLANT-UTIL-V21AX NOT = SPACE
- 112500 MOVE 01ASTRK-L TO CLS-PLANT-UTIL-DL1B21
- 112600 MOVE 1 TO DATA-FLG.
- 112700 IF AVG-HGT-PLANT-INGR-V21AX NOT = SPACE
- 112800 MOVE 03ASTRKS-L TO AVG-HGT-PLANT-INGR-DL1B21
- 112900 MOVE 1 TO DATA-FLG.
- 113000 IF AVG-HGT-PLANT-FRC-V21AX NOT = SPACE
- 113100 MOVE 02ASTRKS-L TO AVG-HGT-PLANT-FRC-DL1B21
- 113200 MOVE 1 TO DATA-FLG.
- 113300 IF AVG-LDR-LGT-INGR-V21AX NOT = SPACE
- 113400 MOVE 03ASTRKS-L TO AVG-LDR-LGT-INGR-DL1B21
- 113500 MOVE 1 TO DATA-FLG.
- 113600 IF AVG-LDR-LGT-FRC-V21AX NOT = SPACE
- 113700 MOVE 02ASTRKS-L TO AVG-LDR-LGT-FRC-DL1B21
- 113800 MOVE 1 TO DATA-FLG.
- 113900 IF AVG-CRN-DIA-INGR-V21AX NOT = SPACE
- 114000 MOVE 03ASTRKS-L TO AVG-CRN-DIA-INGR-DL1B21
- 114100 MOVE 1 TO DATA-FLG.
- 114200 IF AVG-CRN-DIA-FRC-V21AX NOT = SPACE
- 114300 MOVE 02ASTRKS-L TO AVG-CRN-DIA-FRC-DL1B21
- 114400 MOVE 1 TO DATA-FLG.
- 114500 IF DATA-FLG ZERO
- 114600 MOVE ZERO TO PHNO-STG-V21AZ, CLS-PLANT-UTIL-V21AZ.
- 114700 GO TO 5200.
- 114800 5150.
- 114900 IF AGE-CLS-PLANT-V21AX NOT = SPACE
- 115000 AND "D" AND "M" AND "O" AND "P" AND "R" AND "S" AND "Y"
- 115100 MOVE 01ASTRK-L TO AGE-CLS-PLANT-DL1B21
- 115200 MOVE 1 TO DATA-FLG.
- 115300 IF FORM-CLS-PLANT-V21AX = SPACE
- 115400 MOVE ZERO TO FORM-CLS-PLANT-V21AZ
- 115500 ELSE IF FORM-CLS-PLANT-V21AX < "1" OR > "4"
- 115600 MOVE 01ASTRK-L TO FORM-CLS-PLANT-DL1B21
- 115700 MOVE 1 TO DATA-FLG.
- 115800 IF PHNO-STG-V21AX = SPACE MOVE ZERO TO PHNO-STG-V21AZ
- 115900 ELSE IF PHNO-STG-V21AX < "1" OR > "9"
- 116000 MOVE 01ASTRK-L TO PHNO-STG-DL1B21 MOVE 1 TO DATA-FLG.
- 116100 IF CLS-PLANT-AVAIL-V21AX NOT =
- 116200 SPACE AND "A" AND "H" AND "L" AND "P" AND "U"
- 116300 MOVE 01ASTRK-L TO CLS-PLANT-AVAIL-DL1B21
- 116400 MOVE 1 TO DATA-FLG.
- 116500 IF CLS-PLANT-UTIL-V21AX = SPACE
- 116600 MOVE ZERO TO CLS-PLANT-UTIL-V21AZ
- 116700 ELSE IF CLS-PLANT-UTIL-V21AX < ZERO OR > "5"
- 116800 MOVE 01ASTRK-L TO CLS-PLANT-UTIL-DL1B21
- 116900 MOVE 1 TO DATA-FLG.
- 117000 5200.
- 117100 MOVE SPACES TO GRP-V21AZ.
- 117200 IF AVG-HGT-PLANT-V21AX = SPACES
- 117300 MOVE ZERO TO AVG-HGT-PLANT-V21AZ GO TO 5300.
- 117400 MOVE AVG-HGT-PLANT-V21AX TO INGR-FRC-H. PERFORM 9600.
- 117500 IF INGR-FLG NOT ZERO
- 117600 MOVE 03ASTRKS-L TO AVG-HGT-PLANT-INGR-DL1B21
- 117700 MOVE 1 TO DATA-FLG.
- 117800 IF FRC-FLG NOT ZERO
- 117900 MOVE 02ASTRKS-L TO AVG-HGT-PLANT-FRC-DL1B21
- 118000 MOVE 1 TO DATA-FLG.
- 118100 IF DATA-FLG ZERO
- 118200 MOVE INGR-3C-FRC-1C-H TO AVG-HGT-PLANT-V21AZ.
- 118300 5300.
- 118400 IF CHARZD-NUM-V21AX = SPACE
- 118500 MOVE ZERO TO CHARZD-NUM-V21AZ
- 118600 ELSE IF CHARZD-NUM-V21AX NUMERIC
- 118700 MOVE CHARZD-NUM-V21AX TO CHARZD-NUM-V21AZ
- 118800 ELSE MOVE 03ASTRKS-L TO CHARZD-NUM-DL1B21
- 118900 MOVE 1 TO DATA-FLG.
- 119000 IF AVG-LDR-LGT-V21AX = SPACES
- 119100 MOVE ZERO TO AVG-LDR-LGT-V21AZ GO TO 5400.
- 119200 MOVE AVG-LDR-LGT-V21AX TO INGR-FRC-H. PERFORM 9600.
- 119300 IF INGR-FLG NOT ZERO
- 119400 MOVE 03ASTRKS-L TO AVG-LDR-LGT-INGR-DL1B21
- 119500 MOVE 1 TO DATA-FLG.
- 119600 IF FRC-FLG NOT ZERO
- 119700 MOVE 02ASTRKS-L TO AVG-LDR-LGT-FRC-DL1B21
- 119800 MOVE 1 TO DATA-FLG.
- 119900 IF DATA-FLG ZERO
- 120000 MOVE INGR-2C-FRC-1C-H TO AVG-LDR-LGT-V21AZ.
- 120100 5400.
- 120200 IF AVG-CRN-DIA-V21AX = SPACES
- 120300 MOVE ZERO TO AVG-CRN-DIA-V21AZ GO TO 5500.
- 120400 MOVE AVG-CRN-DIA-V21AX TO INGR-FRC-H. PERFORM 9600.
- 120500 IF INGR-FLG NOT ZERO
- 120600 MOVE 03ASTRKS-L TO AVG-CRN-DIA-INGR-DL1B21
- 120700 MOVE 1 TO DATA-FLG.
- 120800 IF FRC-FLG NOT ZERO
- 120900 MOVE 02ASTRKS-L TO AVG-CRN-DIA-FRC-DL1B21
- 121000 MOVE 1 TO DATA-FLG.
- 121100 IF DATA-FLG ZERO
- 121200 MOVE INGR-2C-FRC-1C-H TO AVG-CRN-DIA-V21AZ.
- 121300 5500.
- 121400 IF CHARZD-NOT-NUM-V21AX = SPACE
- 121500 MOVE ZERO TO CHARZD-NOT-NUM-V21AZ
- 121600 ELSE IF CHARZD-NOT-NUM-V21AX NUMERIC
- 121700 MOVE CHARZD-NOT-NUM-V21AX TO CHARZD-NOT-NUM-V21AZ
- 121800 ELSE MOVE 03ASTRKS-L TO CHARZD-NOT-NUM-DL1B21
- 121900 MOVE 1 TO DATA-FLG.
- 122000 IF DATA-FLG ZERO
- 122100 MOVE MAST-CROPS-CD-V21AX TO MAST-CROPS-CD-V21AZ
- 122200 GO TO 7000.
- 122300 IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-V11X
- 122400 MOVE COL-HDRA21 TO COL-HDR2A1
- 122500 MOVE COL-HDRB21 TO COL-HDR2B1
- 122600 MOVE COL-HDRC21 TO COL-HDR2C1
- 122700 MOVE 1 TO RITE-HDR-FLG.
- 122800 MOVE PLOT-SIZ-V21AX TO PLOT-SIZ-DL1A21.
- 122900 MOVE PLOT-NUM-V21AX TO PLOT-NUM-DL1A21.
- 123000 MOVE PLANT-CD-V21AX TO PLANT-CD-DL1A21.
- 123100 MOVE AGE-CLS-PLANT-V21AX TO AGE-CLS-PLANT-DL1A21.
- 123200 MOVE FORM-CLS-PLANT-V21AX TO FORM-CLS-PLANT-DL1A21.
- 123300 MOVE PHNO-STG-V21AX TO PHNO-STG-DL1A21.
- 123400 MOVE CLS-PLANT-AVAIL-V21AX TO CLS-PLANT-AVAIL-DL1A21.
- 123500 MOVE CLS-PLANT-UTIL-V21AX TO CLS-PLANT-UTIL-DL1A21.
- 123600 IF AVG-HGT-PLANT-V21AX NOT = SPACES
- 123700 MOVE AVG-HGT-PLANT-INGR-V21AX
- 123800 TO AVG-HGT-PLANT-INGR-DL1A21
- 123900 MOVE "." TO AVG-HGT-PLANT-DEC-DL1A21
- 124000 MOVE AVG-HGT-PLANT-FRC-V21AX TO AVG-HGT-PLANT-FRC-DL1A21.
- 124100 MOVE CHARZD-NUM-V21AX TO CHARZD-NUM-DL1A21.
- 124200 IF AVG-LDR-LGT-V21AX NOT = SPACES
- 124300 MOVE AVG-LDR-LGT-INGR-V21AX TO AVG-LDR-LGT-INGR-DL1A21
- 124400 MOVE "." TO AVG-LDR-LGT-DEC-DL1A21
- 124500 MOVE AVG-LDR-LGT-FRC-V21AX TO AVG-LDR-LGT-FRC-DL1A21.
- 124600 IF AVG-CRN-DIA-V21AX NOT = SPACES
- 124700 MOVE AVG-CRN-DIA-INGR-V21AX TO AVG-CRN-DIA-INGR-DL1A21
- 124800 MOVE "." TO AVG-CRN-DIA-DEC-DL1A21
- 124900 MOVE AVG-CRN-DIA-FRC-V21AX TO AVG-CRN-DIA-FRC-DL1A21.
- 125000 MOVE CHARZD-NOT-NUM-V21AX TO CHARZD-NOT-NUM-DL1A21.
- 125100 MOVE MAST-CROPS-CD-V21AX TO MAST-CROPS-CD-DL1A21.
- 125200 GO TO 7100.
- 125300 6000.
- 125400 ADD 1 TO CNT-V3.
- 125500 IF FMT-CD-V11X NOT = "B"
- 125600 ADD 1 TO CNT-BAD-CODE
- 125700 DISPLAY "BAD REC CODE= " V11X
- 125800 GO TO 0100 .
- 125900* ELSE DISPLAY V11X.
- 126000 IF PLANT-CD-V3XBX NOT = "BARREN " GO TO 6200.
- 126100 MOVE SPACES TO V3XBZ.
- 126200 MOVE ZERO TO PLOT-TOT-NUM-V3XBZ, PLOT-SIZ-EST-V3XBZ,
- 126300 HGT-CLS-CD-V3XBZ.
- 126400 MOVE PLANT-CD-V3XBX TO PLANT-CD-V3XBZ. MOVE 1 TO SS2A.
- 126500 6100.
- 126600 MOVE ZERO TO PHNO-STG-T-PROD-WGT-V3XBZ (SS2A).
- 126700 IF SS2A < 10 ADD 1 TO SS2A GO TO 6100. GO TO 7000.
- 126800 6200.
- 126900 MOVE PLANT-CD-V3XBX TO PLT-HLD.
- 127000 PERFORM 9900-PLT-CNV.
- 127100 MOVE PLT-HLD TO PLANT-CD-V3XBX.
- 127200 IF PLOT-TOT-NUM-V3XBX NOT NUMERIC
- 127300 OR PLOT-TOT-NUM-V3XBX NOT > ZERO
- 127400 MOVE 02ASTRKS-L TO PLOT-TOT-NUM-DL1B3B
- 127500 MOVE 1 TO DATA-FLG.
- 127600 MOVE PLOT-SIZ-EST-V3XBX TO PLOT-SIZ-EST-V3XBX-H.
- 127700 PERFORM 9800. IF INGR-FLG NOT ZERO
- 127800 MOVE 05ASTRKS-L TO PLOT-SIZ-EST-INGR-DL1B3B
- 127900 MOVE 1 TO DATA-FLG.
- 128000 IF FRC-FLG NOT ZERO
- 128100 MOVE 02ASTRKS-L TO PLOT-SIZ-EST-FRC-DL1B3B
- 128200 MOVE 1 TO DATA-FLG.
- 128300 MOVE PLANT-CD-V3XBX TO DE-CD-8822-DEC.
- 128400 PERFORM 9200. IF PLANT-CD-FLG NOT ZERO
- 128500 MOVE 07ASTRKS-L TO PLANT-CD-DL1B3B
- 128600 MOVE 1 TO DATA-FLG
- 128700 ELSE MOVE PLANT-TYP-H TO PLANT-TYP-V3XBZ.
- 128800 IF HGT-CLS-CD-V3XBX < "1" OR > "4"
- 128900 MOVE 01ASTRK-L TO HGT-CLS-CD-DL1B3B
- 129000 MOVE 1 TO DATA-FLG. MOVE 1 TO SS2A.
- 129100 6300.
- 129200 MOVE GRP-V3XBX (SS2A) TO GRP-V3XBX-H.
- 129300 IF HRBG-PROD-WGT-V3XBX-H = ZERO
- 129400 MOVE SPACES TO HRBG-PROD-WGT-V3XBX-H.
- 129500 IF GRP-V3XBX-H = SPACES
- 129600 MOVE ZERO TO PHNO-STG-T-PROD-WGT-V3XBZ (SS2A)
- 129700 GO TO 6400.
- 129800 IF HRBG-PROD-WGT-V3XBX-H = SPACES
- 129900 MOVE ZERO TO HRBG-PROD-WGT-V3XBZ (SS2A)
- 130000 ELSE IF HRBG-PROD-WGT-V3XBX-H NOT NUMERIC
- 130100 MOVE 04ASTRKS-L TO HRBG-PROD-WGT-DL1B3B (SS2A)
- 130200 MOVE 1 TO DATA-FLG.
- 130300 IF CLS-PLANT-AVAIL-V3XBX-H NOT =
- 130400 "A" AND "H" AND "L" AND "P" AND "U"
- 130500 MOVE 01ASTRK-L TO CLS-PLANT-AVAIL-DL1B3B (SS2A)
- 130600 MOVE 1 TO DATA-FLG.
- 130700 IF PHNO-STG-V3XBX-H < "1" OR > "8"
- 130800 MOVE 01ASTRK-L TO PHNO-STG-DL1B3B (SS2A)
- 130900 MOVE 1 TO DATA-FLG.
- 131000 IF CLS-PLANT-UTIL-V3XBX-H NOT NUMERIC
- 131100 OR CLS-PLANT-UTIL-V3XBX-H > "5"
- 131200 MOVE 01ASTRK-L TO CLS-PLANT-UTIL-DL1B3B (SS2A)
- 131300 MOVE 1 TO DATA-FLG.
- 131400 6400.
- 131500 IF SS2A < 10 ADD 1 TO SS2A GO TO 6300.
- 131600 IF DATA-FLG ZERO
- 131700 MOVE PLOT-SIZ-EST-D3XBZ-H TO PLOT-SIZ-EST-V3XBZ
- 131800 MOVE SPACES TO PLOT-SIZ-FIL-V3XBZ GO TO 7000.
- 131900 MOVE FMT-NUM-V11X TO FMT-NUM-DL1A.
- 132000 IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-V11X
- 132100 MOVE COL-HDRA3B TO COL-HDR2A1
- 132200 MOVE COL-HDRB3B TO COL-HDR2B1
- 132300 MOVE COL-HDRC3B TO COL-HDR2C1
- 132400 MOVE 1 TO RITE-HDR-FLG.
- 132500 MOVE PLOT-TOT-NUM-V3XBX TO PLOT-TOT-NUM-DL1A3B.
- 132600 IF PLOT-SIZ-EST-V3XBX NOT = SPACES
- 132700 MOVE PLOT-SIZ-EST-INGR-V3XBX TO PLOT-SIZ-EST-INGR-DL1A3B
- 132800 MOVE "." TO PLOT-SIZ-EST-DEC-DL1A3B
- 132900 MOVE PLOT-SIZ-EST-FRC-V3XBX TO PLOT-SIZ-EST-FRC-DL1A3B.
- 133000 MOVE PLANT-CD-V3XBX TO PLANT-CD-DL1A3B.
- 133100 MOVE HGT-CLS-CD-V3XBX TO HGT-CLS-CD-DL1A3B.
- 133200 MOVE 1 TO SS2A.
- 133300 6500.
- 133400 MOVE GRP-V3XBX (SS2A) TO GRP2-DL1A3B (SS2A).
- 133500 IF SS2A < 10 ADD 1 TO SS2A GO TO 6500. GO TO 7100.
- 133600 7000.
- 133700 MOVE V11Z TO REC-D1. WRITE REC-D1.
- 133800 ADD 1 TO OT-CNTR. GO TO 0100.
- 133900 7100.
- 134000 MOVE REC-TYP-T-FMT-CD-V11X
- 134100 TO REC-TYP-T-FMT-CD-DL1A.
- 134200 MOVE ACTN-CD-V11X TO ACTN-CD-DL1A.
- 134300 MOVE LIN-NUM-V11X TO LIN-NUM-DL1A.
- 134400 7200.
- 134500 MOVE ZERO TO LIN-CNT.
- 134600 IF RITE-HDR-FLG NOT ZERO ADD 4 TO LIN-CNT.
- 134700 IF RITE-KEY-FLG NOT ZERO ADD 6 TO LIN-CNT
- 134800 IF KEY-FLG NOT ZERO ADD 1 TO LIN-CNT.
- 134900 ADD 3 TO LIN-CNT. ADD LIN-CNT TO LIN-CHK.
- 135000 IF LIN-CHK > 48 ADD 1 TO PAG-CNT
- 135100 MOVE PAG-CNT TO PAG-CNT-PH1 MOVE ZERO TO LIN-CHK
- 135200 MOVE 1 TO RITE-HDR-FLG MOVE PAG-HDR1 TO REC-P1
- 135300 WRITE REC-P1 AFTER ADVANCING PAGE
- 135400 MOVE PAG-HDR2 TO REC-P1
- 135500 WRITE REC-P1 AFTER ADVANCING 2 LINES
- 135600 MOVE PAG-HDR3 TO REC-P1 WRITE REC-P1
- 135700 MOVE PAG-HDR4 TO REC-P1
- 135800 WRITE REC-P1 AFTER ADVANCING 2 LINES
- 135900 MOVE PAG-HDR5 TO REC-P1 WRITE REC-P1
- 136000 MOVE PAG-HDR6 TO REC-P1 WRITE REC-P1 GO TO 7200.
- 136100 IF RITE-KEY-FLG ZERO GO TO 7400.
- 136200 MOVE ZERO TO RITE-KEY-FLG.
- 136300 MOVE COL-HDR1A TO REC-P1.
- 136400 WRITE REC-P1 AFTER ADVANCING 2 LINES.
- 136500 MOVE COL-HDR1B TO REC-P1. WRITE REC-P1.
- 136600 MOVE COL-HDR1C TO REC-P1. WRITE REC-P1.
- 136700 MOVE KEY-LIN1A TO REC-P1.
- 136800 WRITE REC-P1 AFTER ADVANCING 2 LINES.
- 136900 IF KEY-FLG NOT ZERO
- 137000 MOVE KEY-LIN1B TO REC-P1 WRITE REC-P1.
- 137100 7400.
- 137200 IF RITE-HDR-FLG NOT ZERO
- 137300 MOVE ZERO TO RITE-HDR-FLG
- 137400 MOVE COL-HDR2A TO REC-P1
- 137500 WRITE REC-P1 AFTER ADVANCING 2 LINES
- 137600 MOVE COL-HDR2B TO REC-P1 WRITE REC-P1
- 137700 MOVE COL-HDR2C TO REC-P1 WRITE REC-P1.
- 137800 MOVE DATA-LIN1A TO REC-P1.
- 137900 WRITE REC-P1 AFTER ADVANCING 2 LINES.
- 138000 MOVE DATA-LIN1B TO REC-P1. WRITE REC-P1.
- 138100 MOVE SPACES TO DATA-LIN1A11, DATA-LIN1B11.
- 138200 ADD 1 TO PT-CNTR. GO TO 0100.
- 138300 9200.
- 138400 MOVE DE-CD-8822-DEC TO PLT-SRC.
- 138500 MOVE ZERO TO PLANT-CD-FLG. MOVE 2646 TO DE-NO-8801-DEC.
- 138600 FIND ANY CODE-DEC.
- 138700 IF DB-STATUS NOT = ZERO MOVE 1 TO PLANT-CD-FLG
- 138800 ELSE GET CODE-DEC
- 138900 MOVE CODE-DEC TO CODE-DEC-H
- 139000 IF PLANT-TYP-H NOT = "F" AND "G" AND "S" AND "T"
- 139100 MOVE 1 TO PLANT-CD-FLG.
- 139200 IF PLANT-CD-FLG = 1
- 139300 PERFORM 9910-PLT-STORE THRU 9940-EXIT.
- 139400 9600.
- 139500 MOVE ZERO TO FRC-FLG, INGR-FLG.
- 139600 EXAMINE INGR-FRC-H REPLACING ALL SPACES BY ZERO.
- 139700 IF INGR-H NOT NUMERIC MOVE 1 TO INGR-FLG.
- 139800 IF FRC-H NOT NUMERIC MOVE 1 TO FRC-FLG.
- 139900 IF FRC-FLG ZERO AND INGR-FLG ZERO
- 140000 ADD .05 TO INGR-3C-FRC-2C-H.
- 140100 9800.
- 140200 MOVE ZERO TO FRC-FLG, INGR-FLG.
- 140300 EXAMINE PLOT-SIZ-C3T7-V3XBX-H REPLACING ALL SPACES BY ZERO.
- 140400 IF PLOT-SIZ-C3T5-V3XBX-H NOT NUMERIC MOVE 1 TO INGR-FLG.
- 140500 IF PLOT-SIZ-C6T7-V3XBX-H NOT NUMERIC MOVE 1 TO FRC-FLG.
- 140600 IF PLOT-SIZ-EST-D3XBZ-H < .01 MOVE 1 TO FRC-FLG, INGR-FLG.
- 140700 9900-PLT-CNV.
- 140800 IF PLT-HLD = "MOSS "
- 140900 MOVE "MMMM " TO PLT-HLD.
- 141000 IF PLT-HLD = "RHRA "
- 141100 MOVE "TORY " TO PLT-HLD.
- 141200 IF PLT-HLD = "LICHEN "
- 141300 MOVE "SILEN " TO PLT-HLD.
- 141400 IF PLT-HLD = "ARTRZ "
- 141500 MOVE "ARTR2 " TO PLT-HLD.
- 141600 IF PLT-HLD = "CHDEZ "
- 141700 MOVE "CHDE2 " TO PLT-HLD.
- 141800 IF PLT-HLD = "GIPOZ "
- 141900 MOVE "GIPO2 " TO PLT-HLD.
- 142000 IF PLT-HLD = "CACRII "
- 142100 MOVE "CHCR11 " TO PLT-HLD.
- 142200 IF PLT-HLD = "CACRLL "
- 142300 MOVE "CHCR11 " TO PLT-HLD.
- 142400 IF PLT-HLD = "HAARZ "
- 142500 MOVE "HAAR2 " TO PLT-HLD.
- 142600 IF PLT-HLD = "TESPZ "
- 142700 MOVE "TESP2 " TO PLT-HLD.
- 142800 IF PLT-HLD = "PHLOZ "
- 142900 MOVE "PHLO2 " TO PLT-HLD.
- 143000 IF PLT-HLD = "POATT "
- 143100 MOVE "POA++ " TO PLT-HLD.
- 143200 IF PLT-HLD = "POA "
- 143300 MOVE "POA++ " TO PLT-HLD.
- 143400 IF PLT-HLD = "EULAS "
- 143500 MOVE "EULA5 " TO PLT-HLD.
- 143600* IF PLT-HLD = "X"
- 143700* MOVE "Z" TO PLT-HLD.
- 143800 9910-PLT-STORE.
- 143900 MOVE 0 TO PLT-SUB.
- 144000 9920-LP.
- 144100 ADD 1 TO PLT-SUB.
- 144200 IF PLT-SUB > 200 GO TO 9940-EXIT.
- 144300 IF PLT-TB (PLT-SUB) = SPACE
- 144400 MOVE PLT-SRC TO PLT-TB (PLT-SUB)
- 144500 MOVE 1 TO PLT-CNT (PLT-SUB)
- 144600 GO TO 9940-EXIT.
- 144700 IF PLT-SRC = PLT-TB (PLT-SUB)
- 144800 ADD 1 TO PLT-CNT (PLT-SUB)
- 144900 GO TO 9940-EXIT.
- 145000 GO TO 9920-LP.
- 145100 9940-EXIT.
- 145200 EXIT.
- 145300 9950-WRAP-UP.
- 145400 MOVE 0 TO PLT-SUB.
- 145500 9960-LP.
- 145600 ADD 1 TO PLT-SUB.
- 145700 IF PLT-SUB > 200 GO TO 9970-STOP.
- 145800 IF PLT-TB (PLT-SUB) = SPACE GO TO 9970-STOP.
- 145900 DISPLAY PLT-TB (PLT-SUB) " " PLT-CNT (PLT-SUB).
- 146000 GO TO 9960-LP.
- 146100 9970-STOP.
- 146200 DISPLAY "RECORDS OUT = ", OT-CNTR.
- 146300 DISPLAY "BAD RECORDS = ", PT-CNTR.
- 146400 DISPLAY "RECORDS IN = ", IN-CNTR.
- 146500 DISPLAY "V1 RECORDS = " CNT-V1.
- 146600 DISPLAY "V2 RECORDS = " CNT-V2.
- 146700 DISPLAY "V3 RECORDS = " CNT-V3.
- 146800 DISPLAY "BAD-PU-CNT = " CNT-BAD-PU.
- 146900 DISPLAY "BAD-ALOT-CNT= " CNT-BAD-PU.
- 147000 CLOSE FIL-I1, FIL-D1, FIL-P1
- 147100 FINISH DIC-DE
- 147200 STOP RUN.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES040X.
- 000300* BUILDS WORK FILES FOR INPUT TO PLANT SUMMARY PROGRAM.
- 000400*
- 000500 AUTHOR. RON BAKER.
- 000600 DATE-WRITTEN. 05/05/80.
- 000700 DATE-COMPILED.
- 000800 ENVIRONMENT DIVISION.
- 000900 CONFIGURATION SECTION.
- 001000 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001100 OBJECT-COMPUTER. LEVEL-66-ASCII, SEQUENCE IS EBCDIC.
- 001200 INPUT-OUTPUT SECTION.
- 001300 FILE-CONTROL.
- 001400 SELECT FILE-P1 ASSIGN TO P1
- 001500 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001600 SELECT FILE-D4 ASSIGN TO D4
- 001700 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001800 SELECT FILE-D1 ASSIGN TO D1
- 001900 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002000 SELECT FILE-D2 ASSIGN TO D2
- 002100 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002200 SELECT FILE-D3 ASSIGN TO D3
- 002300 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002400 DATA DIVISION.
- 002500 FILE SECTION.
- 002600 FD FILE-D4
- 002700 CODE-SET IS GBCD
- 002800 LABEL RECORDS ARE STANDARD
- 002900 DATA RECORD IS FDR-D4.
- 003000 01 FDR-D4.
- 003100 03 FILLER PIC XXXX.
- 003200 03 REC-TYP-D4 PIC XXXX.
- 003300 03 FILLER PIC X(134).
- 003400 03 PAST-NUM-D4-IN PIC XX.
- 003500 FD FILE-D1
- 003600 CODE-SET IS GBCD
- 003700 LABEL RECORDS ARE STANDARD
- 003800 DATA RECORD IS FDR-D1.
- 003900 01 FDR-D1 PIC X(102).
- 004000 FD FILE-D2
- 004100 CODE-SET IS GBCD
- 004200 LABEL RECORDS ARE STANDARD
- 004300 DATA RECORD IS FDR-D2.
- 004400 01 FDR-D2 PIC X(24).
- 004500 FD FILE-D3
- 004600 CODE-SET IS GBCD
- 004700 LABEL RECORDS ARE STANDARD
- 004800 DATA RECORD IS FDR-D3.
- 004900 01 FDR-D3 PIC X(126).
- 005000 FD FILE-P1
- 005100 CODE-SET IS GBCD
- 005200 LABEL RECORDS ARE STANDARD
- 005300 DATA RECORD IS FDR-P1.
- 005400 01 FDR-P1.
- 005500 03 SH-P PIC X(20).
- 005600 03 RC-P PIC X(112).
- 005700 WORKING-STORAGE SECTION.
- 005800 77 SUB-03 PIC 99 VALUE ZERO.
- 005900 77 REC-TYP-IN PIC 9 VALUE ZERO.
- 006000 77 WORK-STATUS PIC XXX.
- 006100 77 TAB-KEY-HLD PIC 99 VALUE ZERO.
- 006200 77 BY-2-SW PIC 9 VALUE ZERO.
- 006300 77 FIRST-RK9-SW PIC 9 VALUE ZERO.
- 006400 77 BY-2-SW PIC 9 VALUE ZERO.
- 006500 77 BY-SWAT-SW PIC 9 VALUE ZERO.
- 006600 77 BAD-SW PIC 9 VALUE ZERO.
- 006700 77 SUB-01 PIC 99 VALUE ZERO.
- 006800 77 SUB-5 PIC 99 VALUE ZERO.
- 006900 77 SLT-SUB PIC 99 VALUE ZERO.
- 007000 77 TK-HLD PIC 99 VALUE ZERO.
- 007100 77 SUB-02 PIC 99 VALUE ZERO.
- 007200 77 SUB-GC PIC 99 VALUE ZERO.
- 007300 77 SWAT-NO-REL PIC X(20) VALUE SPACE.
- 007400 77 ALLOT-NUM-HLD PIC 9999.
- 007500 COPY V11Z OF LIBRARY1.
- 007600 01 REC-KEY9.
- 007700 03 SDRP-RK9.
- 007800 05 ADST-CD-RK9 PIC XX.
- 007900 05 DIST-CD-RK9 PIC 99.
- 008000 05 RA-CD-RK9 PIC 99.
- 008100 05 PLU-CD-RK9 PIC 99.
- 008200 03 SWAT-RK9 PIC X(6).
- 008300 03 REC-KEY-RK9 PIC 9.
- 008400 03 PLOTS-RK9 PIC 99.
- 008500 03 FILLER PIC X(7).
- 008600 01 CNTL-HLD.
- 008700 03 SDRP-SH.
- 008800 05 ADST-CD-SH PIC XX.
- 008900 05 DIST-CD-SH PIC 99.
- 009000 05 RA-CD-SH PIC 99.
- 009100 05 PLU-CD-SH PIC 99.
- 009200 03 ALLOT-NUM-SH PIC 9999.
- 009300 03 PASTURE-NUM-SH PIC 99.
- 009400 03 SWAT-SH.
- 009500 05 SWA-SH.
- 009600 07 SWA-CD PIC X.
- 009700 07 SWA-NUM PIC 999.
- 009800 05 TRN-NUM-SH PIC 99.
- 009900 01 CNTL-D4.
- 010000 03 SDRP-D4.
- 010100 05 ADST-CD-D4 PIC XX.
- 010200 05 DIST-CD-D4 PIC 99.
- 010300 05 RA-CD-D4 PIC 99.
- 010400 05 PLU-CD-D4 PIC 99.
- 010500 03 ALLOT-NUM-D4 PIC 9999.
- 010600 03 PASTURE-NUM-D4 PIC 99.
- 010700 03 SWAT-D4.
- 010800 05 SWA-D4.
- 010900 07 SWA-CD-D4 PIC X.
- 011000 07 SWA-NUM-D4 PIC 999.
- 011100 05 TRN-NUM-D4 PIC 99.
- 011200 COPY REC-KEY0 IN LIBRARY.
- 011300 01 REC-KEY1.
- 011400 05 SWAT-RK1 PIC X(20).
- 011500 05 REC-KEY-RK1 PIC 9(1).
- 011600 05 VEG-SUB-TYPE-RK1 PIC 9(4).
- 011700 05 SWA-PCT-RK1 PIC 9(3).
- 011800 05 CMPR-ID-FLAG-RK1 PIC X(1).
- 011900 05 SSF-GRP-RK1 PIC X(14).
- 012000 05 SSF-VAL-RAT-RK1 REDEFINES SSF-GRP-RK1
- 012100 OCCURS 7 TIMES PIC 9(2).
- 012200 05 TYP-GC-HITS-GRP-RK1 PIC X(21).
- 012300 05 TYP-GC-HITS-RK1 REDEFINES TYP-GC-HITS-GRP-RK1
- 012400 OCCURS 7 TIMES PIC 9(3).
- 012500 05 FILLER PIC X(38).
- 012600*COPY REC-KEY1 IN LIBRARY.
- 012700 COPY REC-KEY2 IN LIBRARY.
- 012800 COPY REC-KEY3 IN LIBRARY.
- 012900 COPY REC-K4V2 IN LIBRARY.
- 013000 COPY REC-KEY5 IN LIBRARY.
- 013100 COPY REC-KEY7 IN LIBRARY.
- 013200 COPY REC-KEY8 IN LIBRARY.
- 013300 COPY WDB01 IN LIBRARY.
- 013400 COPY WDB02 IN LIBRARY.
- 013500 COPY WDB03 IN LIBRARY.
- 013600*COPY WDB05 IN LIBRARY.
- 013700 01 WDB-05.
- 013800 05 REC-NUM-V21A-WDB PIC 9(2).
- 013900 05 LINE-NUM-V21A-WDB PIC 9(4).
- 014000 05 PLANT-TYP-V21A-WDB PIC X(1).
- 014100 05 PLANT-CD-V21A-WDB PIC X(7).
- 014200 05 AGE-CLS-PLANT-V21A-WDB PIC X(1).
- 014300 05 CLS-PLANT-AVAIL-V21A-WDB PIC X(1).
- 014400 05 PLOT-SIZE-V21A-WDB PIC 9(1).
- 014500 05 PLOT-NUM-V21A-WDB PIC 9(2).
- 014600 05 FORM-CLS-PLANT-V21A-WDB PIC 9(1).
- 014700 05 PHNO-STG-V21A-WDB PIC 9(1).
- 014800 05 CLS-PLANT-UTIL-V21A-WDB PIC 9(1).
- 014900 05 AVG-HGT-PLANT-V21A-WDB PIC 999V9.
- 015000 05 CHARZD-NUM-V21A-WDB PIC 9(3).
- 015100 05 AVG-CROWN-DIA-V21A-WDB PIC 99V9.
- 015200 05 CHARZD-NOT-NUM-V21A-WDB PIC 9(3).
- 015300 COPY WDB10-13 IN LIBRARY.
- 015400 01 TYP-GC-HIT-TABLE.
- 015500 03 TGH-TB PIC 999 OCCURS 7 TIMES.
- 015600 01 SPECIES-LIST-TABLE.
- 015700 03 S-L-TAB.
- 015800 05 S-L-GP OCCURS 100.
- 015900 07 SPEC-TYP-SL PIC X.
- 016000 07 SPEC-SL PIC X(7).
- 016100 03 S-L-TAB-RD REDEFINES S-L-TAB.
- 016200 05 S-L-TB PIC X(80) OCCURS 10 TIMES.
- 016300 01 PLOT-TABLE.
- 016400 03 PLOT-TAB PIC 9 OCCURS 40 TIMES.
- 016500 01 PLOT-SUB PIC 99 VALUE ZERO.
- 016600 01 PLOT-CNT PIC 99 VALUE ZERO.
- 016700 01 CNT-HLD.
- 016800 03 CNT-1 PIC 9(8) VALUE ZERO.
- 016900 03 CNT-2 PIC 9(8) VALUE ZERO.
- 017000 03 CNT-3 PIC 9(8) VALUE ZERO.
- 017100 03 CNT-4 PIC 9(8) VALUE ZERO.
- 017200 03 CNT-5 PIC 9(8) VALUE ZERO.
- 017300 03 CNT-6 PIC 9(8) VALUE 1.
- 017400 01 DISP-REC.
- 017500 03 DISP-1 PIC ZZ,ZZZ,ZZZ.
- 017600 03 FILLER PIC X(12) VALUE " RECS IN ".
- 017700 03 DISP-2 PIC ZZ,ZZZ,ZZZ.
- 017800 03 FILLER PIC X(12) VALUE " TRANSECTS ".
- 017900 03 DISP-3 PIC ZZ,ZZZ,ZZZ.
- 018000 03 FILLER PIC X(12) VALUE " RECS OUT D3".
- 018100 03 DISP-4 PIC ZZ,ZZZ,ZZZ.
- 018200 03 FILLER PIC X(12) VALUE " RECS OUT D1".
- 018300 03 DISP-5 PIC ZZ,ZZZ,ZZZ.
- 018400 03 FILLER PIC X(12) VALUE " RECS OUT D2".
- 018500 03 DISP-6 PIC ZZ,ZZZ,ZZZ.
- 018600 03 FILLER PIC X(12) VALUE " SWAT BREAK ".
- 018700 01 RMK-REC.
- 018800 03 RMK-P PIC X(8) VALUE SPACE.
- 018900 03 DBS-P PIC X(8).
- 019000 03 SWAT-P PIC X(21).
- 019100 01 P-SPACE PIC X(132) VALUE SPACE.
- 019200 PROCEDURE DIVISION.
- 019300 010-HOUSEKEEPING.
- 019400 OPEN OUTPUT FILE-D1 FILE-D3 FILE-P1 FILE-D2.
- 019500 OPEN INPUT FILE-D4.
- 019600 MOVE SPACE TO RMK-REC CNTL-HLD REC-KEY9.
- 019700 INITIALIZE WDB-01 WDB-02 WDB-03
- 019800 PLOT-TABLE
- 019900 WDB-05 WDB-10-13
- 020000 TYP-GC-HIT-TABLE SPECIES-LIST-TABLE.
- 020100 300-FIND-SWAT-CONN.
- 020200 INITIALIZE TAB-KEY-HLD TYP-GC-HIT-TABLE
- 020300 SLT-SUB SPECIES-LIST-TABLE.
- 020400 301-READ.
- 020500 READ FILE-D4 INTO V11Z AT END
- 020600 PERFORM 900-BUILD-REC-1 THRU 930-EXIT
- 020700 GO TO 940-DISPLAY.
- 020800 ADD 1 TO CNT-1.
- 020900 MOVE ADST-CD-V11Z TO ADST-CD-D4.
- 021000 MOVE DIST-CD-V11Z TO DIST-CD-D4.
- 021100 MOVE PLU-CD-V11Z TO PLU-CD-D4.
- 021200 MOVE RA-CD TO RA-CD-D4.
- 021300 MOVE ALLOT-NUM-V11Z TO ALLOT-NUM-D4.
- 021400 IF PAST-NUM-D4-IN NOT = SPACE
- 021500 MOVE PAST-NUM-D4-IN TO PASTURE-NUM-D4
- 021600 ELSE
- 021700 MOVE ZERO TO PASTURE-NUM-D4.
- 021800 MOVE SWA-V11Z TO SWA-D4.
- 021900 MOVE TRN-NUM-V11Z TO TRN-NUM-D4.
- 022000 IF CNTL-HLD = SPACE
- 022100 MOVE CNTL-D4 TO CNTL-HLD.
- 022200 IF CNTL-HLD NOT = CNTL-D4
- 022300 ADD 1 TO CNT-6
- 022400 MOVE ZERO TO FIRST-RK9-SW
- 022500 PERFORM 900-BUILD-REC-1 THRU 930-EXIT
- 022600 MOVE CNTL-D4 TO CNTL-HLD.
- 022700 301-PROCESS.
- 022800 IF (REC-TYP-D4 = "V11A") MOVE 1 TO REC-TYP-IN.
- 022900 IF (REC-TYP-D4 = "V12A") MOVE 2 TO REC-TYP-IN.
- 023000 IF (REC-TYP-D4 = "V13A") MOVE 3 TO REC-TYP-IN.
- 023100 IF (REC-TYP-D4 = "V14A") MOVE 4 TO REC-TYP-IN.
- 023200 IF (REC-TYP-D4 = "V21A") MOVE 5 TO REC-TYP-IN.
- 023300 IF (REC-TYP-D4 = "V31B") MOVE 7 TO REC-TYP-IN.
- 023400 IF (REC-TYP-D4 = "V32B") MOVE 7 TO REC-TYP-IN.
- 023500 IF (REC-TYP-D4 = "V33B") MOVE 7 TO REC-TYP-IN.
- 023600 IF (REC-TYP-D4 = "V34B") MOVE 7 TO REC-TYP-IN.
- 023700 IF REC-TYP-IN NOT = 1
- 023800 GO TO 420-CK-REC.
- 023900 302-BUILD-V11.
- 024000 ADD 1 TO CNT-2.
- 024100 MOVE SPACE TO WDB-01.
- 024200 MOVE ADST-CD-V11Z TO ADST-SI-WDB.
- 024300 MOVE DIST-CD-V11Z TO DIST-SI-WDB.
- 024400 MOVE PLU-CD-V11Z TO PLU-SI-WDB.
- 024500 MOVE RA-CD TO RA-SI-WDB.
- 024600 MOVE SWA-V11Z TO SWA-SI-WDB.
- 024700 MOVE TRN-NUM-V11Z TO TRN-NUM-SI-WDB.
- 024800 MOVE ALLOT-NUM-SH TO ALLOT-NUM-WDB.
- 024900 MOVE PASTURE-NUM-SH TO PASTURE-NUM-WDB.
- 025000 MOVE SPACE TO SWAT-BRWD-WDB.
- 025100 IF (REC-TYP-IN = 1) AND
- 025200 (ADST-CD-V11AZ NOT = SPACE)
- 025300 MOVE "C" TO CMPR-ID-FLAG-WDB
- 025400 ELSE MOVE "S" TO CMPR-ID-FLAG-WDB.
- 025500 302-GO-TO.
- 025600 GO TO 301-READ.
- 025700 420-CK-REC.
- 025800 IF ADST-SI-WDB = SPACE
- 025900 PERFORM 302-BUILD-V11.
- 026000 IF REC-TYP-IN = 3 GO TO 423-REC-V13.
- 026100 IF REC-TYP-IN = 4 GO TO 424-REC-V14.
- 026200 IF REC-TYP-IN = 5 GO TO 425-REC-V21.
- 026300 IF REC-TYP-IN = 7 GO TO 427-REC-V3B.
- 026400 MOVE SPACE TO WDB-02.
- 026500 MOVE LINE-NUM-V11Z TO LINE-NUM-V12A-WDB
- 026600 MOVE 02 TO REC-NUM-V12A-WDB
- 026700 MOVE GRP-V12AZ (1) TO GRP-2-V12A-WDB (1)
- 026800 MOVE GRP-V12AZ (2) TO GRP-2-V12A-WDB (2)
- 026900 MOVE GRP-V12AZ (3) TO GRP-2-V12A-WDB (3)
- 027000 MOVE GRP-V12AZ (4) TO GRP-2-V12A-WDB (4)
- 027100 MOVE TYP-GC-CD-V12AZ TO TYP-GC-CD-V12A-WDB
- 027200 MOVE TYP-GC-HITS-V12AZ TO TYP-GC-HITS-V12A-WDB
- 027300 PERFORM 750-PROC-REC-02 THRU 770-EXIT.
- 027400 GO TO 301-READ.
- 027500 423-REC-V13.
- 027600 MOVE SPACE TO WDB-03.
- 027700 MOVE LINE-NUM-V11Z TO LINE-NUM-V13A-WDB
- 027800 MOVE 03 TO REC-NUM-V13A-WDB
- 027900 MOVE TYP-GC-HITS-V13AZ (1) TO TYP-GC-HITS-V13A-WDB (1)
- 028000 MOVE TYP-GC-HITS-V13AZ (2) TO TYP-GC-HITS-V13A-WDB (2)
- 028100 MOVE PLANT-CD-BL-V13AZ (1) TO PLANT-CD-BL-V13A-WDB (1)
- 028200 MOVE PLANT-CD-BL-V13AZ (2) TO PLANT-CD-BL-V13A-WDB (2)
- 028300 MOVE PLANT-CD-C1-V13AZ (1) TO PLANT-CD-V13A-WDB (1 1)
- 028400 MOVE PLANT-CD-C1-V13AZ (2) TO PLANT-CD-V13A-WDB (2 1)
- 028500 MOVE PLANT-CD-C2-V13AZ (1) TO PLANT-CD-V13A-WDB (1 2)
- 028600 MOVE PLANT-CD-C2-V13AZ (2) TO PLANT-CD-V13A-WDB (2 2)
- 028700 MOVE PLANT-CD-C3-V13AZ (1) TO PLANT-CD-V13A-WDB (1 3)
- 028800 MOVE PLANT-CD-C3-V13AZ (2) TO PLANT-CD-V13A-WDB (2 3)
- 028900 MOVE LEV-TRN-HIT-BL-V13AZ (1) TO LEV-TRN-HIT-BL-V13A-WDB (1)
- 029000 MOVE LEV-TRN-HIT-BL-V13AZ (2) TO LEV-TRN-HIT-BL-V13A-WDB (2)
- 029100 MOVE LEV-TRN-HIT-C1-V13AZ (1) TO LEV-TRN-HIT-V13A-WDB (1 1)
- 029200 MOVE LEV-TRN-HIT-C1-V13AZ (2) TO LEV-TRN-HIT-V13A-WDB (2 1)
- 029300 MOVE LEV-TRN-HIT-C2-V13AZ (1) TO LEV-TRN-HIT-V13A-WDB (1 2)
- 029400 MOVE LEV-TRN-HIT-C2-V13AZ (2) TO LEV-TRN-HIT-V13A-WDB (2 2)
- 029500 MOVE LEV-TRN-HIT-C3-V13AZ (1) TO LEV-TRN-HIT-V13A-WDB (1 3)
- 029600 MOVE LEV-TRN-HIT-C3-V13AZ (2) TO LEV-TRN-HIT-V13A-WDB (2 3)
- 029700 PERFORM 500-BUILD-REC-3 THRU 520-EXIT.
- 029800 GO TO 301-READ.
- 029900 424-REC-V14.
- 030000 MOVE SSF-VAL-RAT-V14AZ (1) TO SSF-VAL-RAT-WDB (1).
- 030100 MOVE SSF-VAL-RAT-V14AZ (2) TO SSF-VAL-RAT-WDB (2).
- 030200 MOVE SSF-VAL-RAT-V14AZ (3) TO SSF-VAL-RAT-WDB (3).
- 030300 MOVE SSF-VAL-RAT-V14AZ (4) TO SSF-VAL-RAT-WDB (4).
- 030400 MOVE SSF-VAL-RAT-V14AZ (5) TO SSF-VAL-RAT-WDB (5).
- 030500 MOVE SSF-VAL-RAT-V14AZ (6) TO SSF-VAL-RAT-WDB (6).
- 030600 MOVE SSF-VAL-RAT-V14AZ (7) TO SSF-VAL-RAT-WDB (7).
- 030700 GO TO 301-READ.
- 030800 425-REC-V21.
- 030900 MOVE SPACE TO WDB-05.
- 031000 MOVE LINE-NUM-V11Z TO LINE-NUM-V21A-WDB.
- 031100 MOVE 05 TO REC-NUM-V13A-WDB.
- 031200 MOVE PLOT-SIZE-V21AZ TO PLOT-SIZE-V21A-WDB.
- 031300 MOVE PLOT-NUM-V21AZ TO PLOT-NUM-V21A-WDB.
- 031400 MOVE CHARZD-NUM-V21AZ TO CHARZD-NUM-V21A-WDB.
- 031500 MOVE PLANT-CD-V21AZ TO PLANT-CD-V21A-WDB.
- 031600 IF PLANT-CD-V21AZ = "BARREN "
- 031700 PERFORM 600-BUILD-RECS-0-6-7 THRU 600-EXIT
- 031800 GO TO 301-READ.
- 031900 MOVE PLANT-TYP-V21AZ TO PLANT-TYP-V21A-WDB.
- 032000 MOVE AGE-CLS-PLANT-V21AZ TO AGE-CLS-PLANT-V21A-WDB.
- 032100 MOVE CLS-PLANT-AVAIL-V21AZ TO CLS-PLANT-AVAIL-V21A-WDB.
- 032200 MOVE FORM-CLS-PLANT-V21AZ TO FORM-CLS-PLANT-V21A-WDB.
- 032300 MOVE PHNO-STG-V21AZ TO PHNO-STG-V21A-WDB.
- 032400 MOVE CLS-PLANT-UTIL-V21AZ TO CLS-PLANT-UTIL-V21A-WDB.
- 032500 MOVE AVG-HGT-PLANT-V21AZ TO AVG-HGT-PLANT-V21A-WDB.
- 032600 MOVE AVG-CRN-DIA-V21AZ TO AVG-CROWN-DIA-V21A-WDB.
- 032700 MOVE CHARZD-NOT-NUM-V21AZ TO CHARZD-NOT-NUM-V21A-WDB.
- 032800 PERFORM 600-BUILD-RECS-0-6-7 THRU 600-EXIT.
- 032900 GO TO 301-READ.
- 033000 427-REC-V3B.
- 033100 IF PLANT-CD-V3XBZ = "BARREN "
- 033200 INITIALIZE WDB-10-13 ELSE
- 033300 MOVE SPACE TO WDB-10-13.
- 033400 MOVE LINE-NUM-V11Z TO LINE-NUM-V3XB-WDB.
- 033500 IF (REC-TYP-D4 = "V31B") MOVE 10 TO REC-NUM-V3XB-WDB.
- 033600 IF (REC-TYP-D4 = "V32B") MOVE 11 TO REC-NUM-V3XB-WDB.
- 033700 IF (REC-TYP-D4 = "V33B") MOVE 12 TO REC-NUM-V3XB-WDB.
- 033800 IF (REC-TYP-D4 = "V34B") MOVE 13 TO REC-NUM-V3XB-WDB.
- 033900* MOVE 10 TO REC-NUM-V3XB-WDB.
- 034000 MOVE PLANT-CD-V3XBZ TO PLANT-CD-V3XB-WDB.
- 034100 MOVE PLOT-TOT-NUM-V3XBZ TO PLOT-TOT-NUM-V3XB-WDB.
- 034200 MOVE PLOT-SIZ-EST-V3XBZ TO PLOT-SIZ-EST-V3XB-WDB.
- 034300 IF PLANT-CD-V3XB-WDB = "BARREN "
- 034400 PERFORM 700-BUILD-REC-5 THRU 720-EXIT
- 034500 GO TO 301-READ.
- 034600 MOVE PLANT-TYP-V3XBZ TO PLANT-TYP-V3XB-WDB.
- 034700 MOVE HGT-CLS-CD-V3XBZ TO HGT-CLS-CD-V3XB-WDB.
- 034800 MOVE PHNO-STG-V3XBZ (1) TO PHNO-STG-V3XB-WDB (1).
- 034900 MOVE PHNO-STG-V3XBZ (2) TO PHNO-STG-V3XB-WDB (2)
- 035000 MOVE PHNO-STG-V3XBZ (3) TO PHNO-STG-V3XB-WDB (3)
- 035100 MOVE PHNO-STG-V3XBZ (4) TO PHNO-STG-V3XB-WDB (4)
- 035200 MOVE PHNO-STG-V3XBZ (5) TO PHNO-STG-V3XB-WDB (5)
- 035300 MOVE PHNO-STG-V3XBZ (6) TO PHNO-STG-V3XB-WDB (6)
- 035400 MOVE PHNO-STG-V3XBZ (7) TO PHNO-STG-V3XB-WDB (7)
- 035500 MOVE PHNO-STG-V3XBZ (8) TO PHNO-STG-V3XB-WDB (8)
- 035600 MOVE PHNO-STG-V3XBZ (9) TO PHNO-STG-V3XB-WDB (9)
- 035700 MOVE PHNO-STG-V3XBZ (10) TO PHNO-STG-V3XB-WDB (10).
- 035800 MOVE CLS-PLANT-UTIL-V3XBZ (1) TO CLS-PLANT-UTIL-V3XB-WDB (1)
- 035900 MOVE CLS-PLANT-UTIL-V3XBZ (2) TO CLS-PLANT-UTIL-V3XB-WDB (2)
- 036000 MOVE CLS-PLANT-UTIL-V3XBZ (3) TO CLS-PLANT-UTIL-V3XB-WDB (3)
- 036100 MOVE CLS-PLANT-UTIL-V3XBZ (4) TO CLS-PLANT-UTIL-V3XB-WDB (4)
- 036200 MOVE CLS-PLANT-UTIL-V3XBZ (5) TO CLS-PLANT-UTIL-V3XB-WDB (5)
- 036300 MOVE CLS-PLANT-UTIL-V3XBZ (6) TO CLS-PLANT-UTIL-V3XB-WDB (6)
- 036400 MOVE CLS-PLANT-UTIL-V3XBZ (7) TO CLS-PLANT-UTIL-V3XB-WDB (7)
- 036500 MOVE CLS-PLANT-UTIL-V3XBZ (8) TO CLS-PLANT-UTIL-V3XB-WDB (8)
- 036600 MOVE CLS-PLANT-UTIL-V3XBZ (9) TO CLS-PLANT-UTIL-V3XB-WDB (9)
- 036700 MOVE CLS-PLANT-UTIL-V3XBZ (10) TO
- 036800 CLS-PLANT-UTIL-V3XB-WDB (10)
- 036900 MOVE HRBG-PROD-WGT-V3XBZ (1) TO HRBG-PROD-WGT-V3XB-WDB (1)
- 037000 MOVE HRBG-PROD-WGT-V3XBZ (2) TO HRBG-PROD-WGT-V3XB-WDB (2)
- 037100 MOVE HRBG-PROD-WGT-V3XBZ (3) TO HRBG-PROD-WGT-V3XB-WDB (3)
- 037200 MOVE HRBG-PROD-WGT-V3XBZ (4) TO HRBG-PROD-WGT-V3XB-WDB (4)
- 037300 MOVE HRBG-PROD-WGT-V3XBZ (5) TO HRBG-PROD-WGT-V3XB-WDB (5)
- 037400 MOVE HRBG-PROD-WGT-V3XBZ (6) TO HRBG-PROD-WGT-V3XB-WDB (6)
- 037500 MOVE HRBG-PROD-WGT-V3XBZ (7) TO HRBG-PROD-WGT-V3XB-WDB (7)
- 037600 MOVE HRBG-PROD-WGT-V3XBZ (8) TO HRBG-PROD-WGT-V3XB-WDB (8)
- 037700 MOVE HRBG-PROD-WGT-V3XBZ (9) TO HRBG-PROD-WGT-V3XB-WDB (9)
- 037800 MOVE HRBG-PROD-WGT-V3XBZ (10) TO HRBG-PROD-WGT-V3XB-WDB (10)
- 037900 MOVE CLS-PLANT-AVAIL-V3XBZ (1) TO
- 038000 CLS-PLANT-AVAIL-V3XB-WDB (1)
- 038100 MOVE CLS-PLANT-AVAIL-V3XBZ (2) TO
- 038200 CLS-PLANT-AVAIL-V3XB-WDB (2)
- 038300 MOVE CLS-PLANT-AVAIL-V3XBZ (3) TO
- 038400 CLS-PLANT-AVAIL-V3XB-WDB (3)
- 038500 MOVE CLS-PLANT-AVAIL-V3XBZ (4) TO
- 038600 CLS-PLANT-AVAIL-V3XB-WDB (4)
- 038700 MOVE CLS-PLANT-AVAIL-V3XBZ (5) TO
- 038800 CLS-PLANT-AVAIL-V3XB-WDB (5)
- 038900 MOVE CLS-PLANT-AVAIL-V3XBZ (6) TO
- 039000 CLS-PLANT-AVAIL-V3XB-WDB (6)
- 039100 MOVE CLS-PLANT-AVAIL-V3XBZ (7) TO
- 039200 CLS-PLANT-AVAIL-V3XB-WDB (7)
- 039300 MOVE CLS-PLANT-AVAIL-V3XBZ (8) TO
- 039400 CLS-PLANT-AVAIL-V3XB-WDB (8)
- 039500 MOVE CLS-PLANT-AVAIL-V3XBZ (9) TO
- 039600 CLS-PLANT-AVAIL-V3XB-WDB (9)
- 039700 MOVE CLS-PLANT-AVAIL-V3XBZ (10) TO
- 039800 CLS-PLANT-AVAIL-V3XB-WDB (10).
- 039900 PERFORM 700-BUILD-REC-5 THRU 720-EXIT.
- 040000 GO TO 301-READ.
- 040100 500-BUILD-REC-3.
- 040200 MOVE SPACE TO REC-KEY3.
- 040300 MOVE ZERO TO SUB-03.
- 040400 MOVE CNTL-HLD TO SWAT-RK3.
- 040500 MOVE 3 TO REC-KEY-RK3.
- 040600 510-LP-TB.
- 040700 IF SUB-03 = 02
- 040800 GO TO 520-EXIT.
- 040900 ADD 1 TO SUB-03.
- 041000 IF PLANT-CD-BL-V13A-WDB (SUB-03) NOT = SPACE
- 041100 MOVE PLANT-CD-BL-V13A-WDB (SUB-03) TO
- 041200 PLANT-CD-BL-RK3
- 041300 MOVE LEV-TRN-HIT-BL-V13A-WDB (SUB-03) TO
- 041400 LEV-TRN-HIT-BL-RK3
- 041500 MOVE PLANT-GRP-1-V13A-WDB (SUB-03) TO GRP-1-RK3
- 041600 MOVE TYP-GC-HITS-V13A-WDB (SUB-03) TO TYP-GC-HITS-RK3
- 041700 WRITE FDR-D1 FROM REC-KEY3
- 041800 ADD 1 TO CNT-4
- 041900 GO TO 510-LP-TB.
- 042000 520-EXIT.
- 042100 EXIT.
- 042200 600-BUILD-RECS-0-6-7.
- 042300 MOVE SPACE TO REC-KEY0.
- 042400 IF PLANT-CD-V21A-WDB = "BARREN "
- 042500 INITIALIZE REC-KEY0.
- 042600 MOVE CNTL-HLD TO SWAT-RK0.
- 042700 MOVE 0 TO REC-KEY-RK0.
- 042800 MOVE "V2" TO REC-TYP-RK0.
- 042900 MOVE 1 TO FMT-NUM-RK0.
- 043000 MOVE "A" TO FMT-CD-RK0.
- 043100 ADD 1 TO TAB-KEY-HLD.
- 043200 MOVE TAB-KEY-HLD TO TAB-KEY-0.
- 043300 MOVE PLANT-CD-V21A-WDB TO SPECIES-KEY-0 PLANT-CD-RK0.
- 043400 MOVE CHARZD-NUM-V21A-WDB TO CHARZD-NUM-RK0.
- 043500 MOVE PLOT-SIZE-V21A-WDB TO PLOT-SIZE-0.
- 043600 MOVE PLOT-NUM-V21A-WDB TO PLOT-NUM-RK0 PLOT-NUM-KEY-0.
- 043700 IF PLANT-CD-V21A-WDB = "BARREN "
- 043800 GO TO 600-WR-REC-KEY-0.
- 043900 MOVE AGE-CLS-PLANT-V21A-WDB TO AGE-CLS-PLANT-RK0.
- 044000 MOVE FORM-CLS-PLANT-V21A-WDB TO FORM-CLS-PLANT-RK0.
- 044100 MOVE PHNO-STG-V21A-WDB TO PHNO-STG-RK0.
- 044200 MOVE CLS-PLANT-AVAIL-V21A-WDB TO CLS-PLANT-AVAIL-RK0.
- 044300 MOVE CLS-PLANT-UTIL-V21A-WDB TO CLS-PLANT-UTIL-RK0.
- 044400 MOVE AVG-HGT-PLANT-V21A-WDB TO AVG-HGT-PLANT-RK0.
- 044500 MOVE AVG-CROWN-DIA-V21A-WDB TO AVG-CROWN-DIA-RK0.
- 044600 MOVE CHARZD-NOT-NUM-V21A-WDB TO CHARZD-NOT-NUM-RK0.
- 044700 MOVE PLANT-TYP-V21A-WDB TO PLANT-TYP-RK0.
- 044800 600-WR-REC-KEY-0.
- 044900 IF ((PLOT-NUM-KEY-0 > ZERO) AND
- 045000 (PLANT-CD-V21A-WDB NOT = "BARREN ")) OR
- 045100 ((PLOT-NUM-KEY-0 > ZERO) AND
- 045200 (PLANT-CD-V21A-WDB = "BARREN ") AND
- 045300 (CHARZD-NUM-V21A-WDB > ZERO))
- 045400 MOVE 1 TO PLOT-TAB (PLOT-NUM-KEY-0).
- 045500 IF PLANT-CD-V21A-WDB = "BARREN "
- 045600 GO TO 600-EXIT.
- 045700 WRITE FDR-D3 FROM REC-KEY0.
- 045800 ADD 1 TO CNT-3.
- 045900 MOVE 6 TO REC-KEY-RK0.
- 046000 MOVE FORM-CLS-PLANT-RK0 TO FORM-CLS-KEY-6.
- 046100 MOVE PLOT-NUM-RK0 TO PLOT-NUM-KEY-6.
- 046200 WRITE FDR-D3 FROM REC-KEY0.
- 046300 ADD 1 TO CNT-3.
- 046400 MOVE 7 TO REC-KEY-RK0.
- 046500 MOVE AGE-CLS-PLANT-RK0 TO AGE-CLS-KEY-7.
- 046600 WRITE FDR-D3 FROM REC-KEY0.
- 046700 ADD 1 TO CNT-3.
- 046800 600-EXIT.
- 046900 EXIT.
- 047000 700-BUILD-REC-5.
- 047100 IF PLANT-CD-V3XB-WDB = "BARREN "
- 047200 INITIALIZE REC-KEY5 ELSE
- 047300 MOVE SPACE TO REC-KEY5.
- 047400 IF FIRST-RK9-SW = ZERO
- 047500* AND (PLANT-CD-V3XB-WDB NOT = "BARREN ")
- 047600 MOVE 1 TO FIRST-RK9-SW
- 047700 MOVE SPACE TO REC-KEY9
- 047800 MOVE SDRP-SH TO SDRP-RK9
- 047900 MOVE 9 TO REC-KEY-RK9
- 048000 MOVE SWAT-SH TO SWAT-RK9
- 048100 MOVE PLOT-TOT-NUM-V3XB-WDB TO PLOTS-RK9
- 048200 ADD 1 TO CNT-5
- 048300 WRITE FDR-D2 FROM REC-KEY9.
- 048400 MOVE CNTL-HLD TO SWAT-RK5.
- 048500 MOVE 5 TO REC-KEY-RK5.
- 048600 MOVE "V3" TO REC-TYP-RK5.
- 048700 MOVE "B" TO FMT-CD-RK5.
- 048800 MOVE PLANT-CD-V3XB-WDB TO PLANT-CD-RK5 SPECIES-KEY-RK5.
- 048900 MOVE PLOT-TOT-NUM-V3XB-WDB TO PLOT-TOT-NUM-RK5.
- 049000 MOVE PLOT-SIZ-EST-V3XB-WDB TO PLOT-SIZ-EST-RK5.
- 049100 IF REC-NUM-V3XB-WDB = 10 MOVE 1 TO FMT-NUM-RK5.
- 049200 IF REC-NUM-V3XB-WDB = 11 MOVE 2 TO FMT-NUM-RK5.
- 049300 IF REC-NUM-V3XB-WDB = 12 MOVE 3 TO FMT-NUM-RK5.
- 049400 IF REC-NUM-V3XB-WDB = 13 MOVE 4 TO FMT-NUM-RK5.
- 049500 IF PLANT-CD-V3XB-WDB = "BARREN "
- 049600 MOVE "ZZBAREN" TO PLANT-CD-RK5 SPECIES-KEY-RK5
- 049700 WRITE FDR-D3 FROM REC-KEY5
- 049800 ADD 1 TO CNT-3
- 049900 GO TO 720-EXIT.
- 050000 MOVE HGT-CLS-CD-V3XB-WDB TO HGT-CLS-CD-RK5.
- 050100 MOVE PLANT-TYP-V3XB-WDB TO PLANT-TYP-RK5.
- 050200 MOVE ZERO TO SUB-5.
- 050300 710-LP-PLOT.
- 050400 ADD 1 TO SUB-5.
- 050500 IF SUB-5 > 10
- 050600 WRITE FDR-D3 FROM REC-KEY5
- 050700 ADD 1 TO CNT-3
- 050800 GO TO 720-EXIT.
- 050900 MOVE GRP-2-V3XB-WDB (SUB-5) TO GRP-3-RK5 (SUB-5).
- 051000 MOVE CLS-PLANT-AVAIL-V3XB-WDB (SUB-5) TO
- 051100 CLS-PLANT-AVAIL-RK5 (SUB-5).
- 051200 GO TO 710-LP-PLOT.
- 051300 720-EXIT.
- 051400 EXIT.
- 051500 750-PROC-REC-02.
- 051600 MOVE ZERO TO SUB-02.
- 051700 MOVE 0 TO SUB-GC.
- 051800 IF (TYP-GC-HITS-V12A-WDB) > ZERO
- 051900 IF TYP-GC-CD-V12A-WDB = "B" MOVE 1 TO SUB-GC ELSE
- 052000 IF TYP-GC-CD-V12A-WDB = "P" MOVE 2 TO SUB-GC ELSE
- 052100 IF TYP-GC-CD-V12A-WDB = "N" MOVE 3 TO SUB-GC ELSE
- 052200 IF TYP-GC-CD-V12A-WDB = "G" MOVE 4 TO SUB-GC ELSE
- 052300 IF TYP-GC-CD-V12A-WDB = "C" MOVE 5 TO SUB-GC ELSE
- 052400 IF TYP-GC-CD-V12A-WDB = "S" MOVE 6 TO SUB-GC ELSE
- 052500 IF TYP-GC-CD-V12A-WDB = "R" MOVE 7 TO SUB-GC.
- 052600 IF SUB-GC > ZERO
- 052700 MOVE TYP-GC-HITS-V12A-WDB TO TGH-TB (SUB-GC).
- 052800 760-LP-TB.
- 052900 ADD 1 TO SUB-02.
- 053000 IF SUB-02 > 4
- 053100 GO TO 770-EXIT.
- 053200 IF PLANT-CD-V12A-WDB (SUB-02) = SPACE
- 053300 GO TO 760-LP-TB.
- 053400 ADD 1 TO SLT-SUB.
- 053500 MOVE PLANT-TYP-V12A-WDB (SUB-02) TO SPEC-TYP-SL (SLT-SUB).
- 053600 MOVE PLANT-CD-V12A-WDB (SUB-02) TO SPEC-SL (SLT-SUB).
- 053700 GO TO 760-LP-TB.
- 053800 770-EXIT.
- 053900 EXIT.
- 054000 800-EXIT.
- 054100 EXIT.
- 054200 900-BUILD-REC-1.
- 054300 MOVE SPACE TO REC-KEY1.
- 054400 MOVE CNTL-HLD TO SWAT-RK1.
- 054500 MOVE 1 TO REC-KEY-RK1.
- 054600 MOVE ZERO TO VEG-SUB-TYPE-RK1 SWA-PCT-RK1.
- 054700 MOVE CMPR-ID-FLAG-WDB TO CMPR-ID-FLAG-RK1.
- 054800 MOVE TYP-GC-HIT-TABLE TO TYP-GC-HITS-GRP-RK1.
- 054900 INITIALIZE TYP-GC-HIT-TABLE.
- 055000 MOVE SSF-GRP-WDB TO SSF-GRP-RK1.
- 055100 WRITE FDR-D1 FROM REC-KEY1.
- 055200 ADD 1 TO CNT-4.
- 055300 MOVE SPACE TO WDB-01.
- 055400* GO TO 925-PLOT-CNT.
- 055500 910-BUILD-REC-2.
- 055600 MOVE ZERO TO SLT-SUB.
- 055700 920-LP-TB.
- 055800 IF SLT-SUB = 10
- 055900 INITIALIZE SPECIES-LIST-TABLE
- 056000 GO TO 925-PLOT-CNT.
- 056100 MOVE SPACE TO REC-KEY2.
- 056200 MOVE CNTL-HLD TO SWAT-RK2.
- 056300 MOVE 2 TO REC-KEY-RK2.
- 056400 ADD 1 TO SLT-SUB.
- 056500 IF S-L-TB (SLT-SUB) = SPACE
- 056600 GO TO 920-LP-TB.
- 056700 MOVE S-L-TB (SLT-SUB) TO GRP-1-RK2
- 056800 WRITE FDR-D1 FROM REC-KEY2
- 056900 ADD 1 TO CNT-4.
- 057000 GO TO 920-LP-TB.
- 057100 925-PLOT-CNT.
- 057200 MOVE SPACE TO SPECIES-KEY-0.
- 057300 MOVE 0 TO REC-KEY-RK0.
- 057400 MOVE ZERO TO PLOT-SUB, PLOT-CNT.
- 057500 925-LP.
- 057600 ADD 1 TO PLOT-SUB.
- 057700 IF PLOT-SUB > 40
- 057800 MOVE PLOT-CNT TO PLOT-NUM-KEY-0
- 057900 MOVE SPACE TO PLANT-CD-RK0
- 058000 WRITE FDR-D3 FROM REC-KEY0
- 058100 ADD 1 TO CNT-3
- 058200 INITIALIZE PLOT-TABLE
- 058300 PLOT-SUB PLOT-CNT
- 058400 GO TO 930-EXIT.
- 058500 IF PLOT-TAB (PLOT-SUB) > ZERO
- 058600 ADD 1 TO PLOT-CNT.
- 058700 GO TO 925-LP.
- 058800 930-EXIT.
- 058900 EXIT.
- 059000 940-DISPLAY.
- 059100 MOVE CNT-1 TO DISP-1.
- 059200 MOVE CNT-2 TO DISP-2.
- 059300 MOVE CNT-3 TO DISP-3.
- 059400 MOVE CNT-4 TO DISP-4.
- 059500 MOVE CNT-5 TO DISP-5.
- 059600 MOVE CNT-6 TO DISP-6.
- 059700 DISPLAY DISP-REC.
- 059800 GO TO 990-END.
- 059900 950-EXIT.
- 060000 EXIT.
- 060100 990-END.
- 060200 CLOSE FILE-D4.
- 060300 CLOSE FILE-D1 FILE-D3 FILE-P1 FILE-D2.
- 060400 STOP RUN.
- 060500 XXXXXX.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES050P.
- 000300* CREATES PLANT SUMMARY FILE
- 000400*
- 000500 AUTHOR. RON BAKER.
- 000600 DATE-WRITTEN. 04/24/79.
- 000700 DATE-COMPILED.
- 000800 ENVIRONMENT DIVISION.
- 000900 CONFIGURATION SECTION.
- 001000 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001100 OBJECT-COMPUTER. LEVEL-66-ASCII, SEQUENCE IS EBCDIC.
- 001200 INPUT-OUTPUT SECTION.
- 001300 FILE-CONTROL.
- 001400 SELECT FILE-D7 ASSIGN TO D7
- 001500 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001600 SELECT FILE-D8 ASSIGN TO D8
- 001700 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001800 SELECT FILE-P1 ASSIGN TO P1
- 001900 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002000 DATA DIVISION.
- 002100 SUB-SCHEMA SECTION.
- 002200 DB CODVAL2 WITHIN BLMDIC.
- 002300 FILE SECTION.
- 002400 FD FILE-D7
- 002500 CODE-SET IS GBCD
- 002600 LABEL RECORDS ARE STANDARD
- 002700 DATA RECORD IS FDR-D7.
- 002800 01 FDR-D7.
- 002900 03 SWAT-CNTL-D7.
- 003000 05 SDRP-D7.
- 003100 07 SD-D7.
- 003200 09 ST-D7 PIC XX.
- 003300 09 DS-D7 PIC XX.
- 003400 07 FILLER PIC X(4).
- 003500 05 FILLER PIC X(12).
- 003600 03 REC-KEY-D7 PIC 9.
- 003700 03 REC-TYP-D7 PIC X(2).
- 003800 03 FMT-NUM-D7 PIC 9.
- 003900 03 FMT-CD-D7 PIC X.
- 004000 03 SORT-CNTL.
- 004100 05 SPECIES-D7 PIC X(7).
- 004200 05 PLOT-TOT-CHRZ-D7 PIC 99.
- 004300 05 FILLER PIC XXX.
- 004400 03 FILLER PIC X(19).
- 004500 03 CN-D7 PIC 999.
- 004600 03 ACD-D7 PIC 999.
- 004700 03 CNN-D7 PIC 999.
- 004800 03 FILLER PIC X(10).
- 004900 03 PN4U PIC 9.
- 005000 03 FILLER PIC X(6).
- 005100 03 PN5U PIC 9.
- 005200 03 FILLER PIC X(34).
- 005300 03 PN10U PIC 9.
- 005400 03 FILLER PIC X(8).
- 005500 FD FILE-D8
- 005600 CODE-SET IS GBCD
- 005700 LABEL RECORDS ARE STANDARD
- 005800 DATA RECORD IS FDR-D8.
- 005900 01 FDR-D8.
- 006000 03 FILLER PIC X(153).
- 006100 03 PLOTS-CHRZ-D8 PIC 99.
- 006200 03 FILLER PIC X.
- 006300 FD FILE-P1
- 006400 CODE-SET IS GBCD
- 006500 LABEL RECORDS ARE STANDARD
- 006600 DATA RECORD IS FDR-P1.
- 006700 01 FDR-P1 PIC X(132).
- 006800 WORKING-STORAGE SECTION.
- 006900 77 SPEC-HLD PIC X(7) VALUE SPACE.
- 007000 77 SWAT-CNTL-BARREN PIC X(20) VALUE SPACE.
- 007100 77 SPEC-TEST-CNT PIC 999 VALUE 000.
- 007200 77 PLOTS-CHRZ-HLD PIC 99 VALUE ZERO.
- 007300 77 PLOTS-CHRZ-HLD-2 PIC 99 VALUE ZERO.
- 007400 77 END-SW PIC 9 VALUE ZERO.
- 007500 77 PRT-SW PIC 9 VALUE 1.
- 007600 77 AVAIL-SW PIC 9 VALUE ZERO.
- 007700 77 CHRZ-SW PIC 9 VALUE 2.
- 007800 77 AUDIT PIC 9 VALUE ZERO.
- 007900 77 HC-HLD PIC 9 VALUE ZERO.
- 008000 77 FC-KEY PIC 9 VALUE ZERO.
- 008100 77 CON96 PIC V99 VALUE .96.
- 008200 77 RK-SW PIC 9 VALUE ZERO.
- 008300 77 AGE PIC 9 VALUE ZERO.
- 008400 77 SUB1 PIC 99 VALUE ZERO.
- 008500 77 SUB2 PIC 99 VALUE ZERO.
- 008600 77 SUB3 PIC 99 VALUE ZERO.
- 008700 77 SUB4 PIC 99 VALUE ZERO.
- 008800 77 SUB5 PIC 99 VALUE ZERO.
- 008900 77 SUB6 PIC 99 VALUE ZERO.
- 009000 77 PLANT-TOT-HLD PIC 999 VALUE ZERO.
- 009100 77 PLANT-TOTAL PIC 9(5) VALUE ZERO.
- 009200 77 TYPE-SPEC-HLD PIC X VALUE SPACE.
- 009300 77 SDRP-HLD PIC X(8) VALUE SPACE.
- 009400 77 SWAT-SW PIC 9 VALUE ZERO.
- 009500 77 SPEC-SW PIC 9 VALUE ZERO.
- 009600 77 PG-CNT PIC 9(5) VALUE ZERO.
- 009700 77 REC-CNT PIC 9(5) VALUE ZERO.
- 009800 77 LINE-CNT PIC 99 VALUE 99.
- 009900 01 HLD-DT.
- 010000 03 YR-DT PIC XX.
- 010100 03 MO-DT PIC 99.
- 010200 03 DY-DT PIC XX.
- 010300 03 FUNC-HLD.
- 010400 05 ST-NM-HLD PIC X(10).
- 010500 05 FILLER PIC X(14).
- 010600 03 EXPL-HLD.
- 010700 05 DIST-NM-HLD PIC X(10).
- 010800 05 FILLER PIC X.
- 010900 05 RA-NM-HLD PIC X(12).
- 011000 05 FILLER PIC X.
- 011100 05 PU-NM-HLD PIC X(15).
- 011200 05 FILLER PIC X.
- 011300 01 FC-AC-CNTL.
- 011400 03 FAC-IN.
- 011500 05 SC-FAC PIC X(20).
- 011600 05 RK-FAC PIC 9.
- 011700 05 SPEC-FAC PIC X(7).
- 011800 05 FAPN-FAC PIC XXX.
- 011900 03 FAC-HLD PIC X(31).
- 012000 01 CONTROL-HLD.
- 012100 03 SWAT-CNTL-HLD.
- 012200 05 SDRP-SCH.
- 012300 07 SDR-SCH.
- 012400 09 SD-SCH.
- 012500 11 ADST-CD-SCH PIC XX.
- 012600 11 DIST-CD-SCH PIC XX.
- 012700 09 RA-CD-SCH PIC XX.
- 012800 07 PLU-CD-SCH PIC XX.
- 012900
- 013000 05 ALLOT-NUM-SCH PIC 9999.
- 013100 05 PASTURE-NUM-SCH PIC 99.
- 013200 05 SWAT-SCH.
- 013300 07 SWA-SCH PIC XXXX.
- 013400 07 TRN-NUM-SCH PIC 99.
- 013500 03 REC-KEY-SCH PIC 9.
- 013600 03 RCD-SCH.
- 013700 05 REC-TYP-SCH PIC X(2).
- 013800 05 FMT-NUM-SCH PIC 9.
- 013900 05 FMT-CD-SCH PIC X.
- 014000 03 KEYS-SCH.
- 014100 05 SPECIES-CD-SCH PIC X(7).
- 014200 05 SK-0.
- 014300 07 PN-S-0 PIC 99.
- 014400 07 FILLER PIC X.
- 014500 05 SK-6 REDEFINES SK-0.
- 014600 07 FC-S-6 PIC 9.
- 014700 07 PN-S-6 PIC 99.
- 014800 05 SK-7 REDEFINES SK-0.
- 014900 07 AC-S-7 PIC X.
- 015000 07 PN-S-7 PIC 99.
- 015100 05 FILLER PIC XX.
- 015200 03 KEYS-IN.
- 015300 05 SPECIES-IN PIC X(7).
- 015400 05 SK-0-IN.
- 015500 07 PN-S-0-IN PIC 99.
- 015600 07 FILLER PIC X.
- 015700 05 SK-6-IN REDEFINES SK-0-IN.
- 015800 07 FC-S-6-IN PIC 9.
- 015900 07 PN-S-6-IN PIC 99.
- 016000 05 SK-7-IN REDEFINES SK-0-IN.
- 016100 07 AC-S-7-IN PIC X.
- 016200 07 PN-S-7-IN PIC 99.
- 016300 05 FILLER PIC XX.
- 016400 01 TABL-AREA.
- 016500 03 MON-V PIC X(36) VALUE "JANFEBMARAPRMAYJUNJULAUGSEPOCT
- 016600- "NOVDEC".
- 016700 03 MON-T REDEFINES MON-V PIC XXX OCCURS 12 TIMES.
- 016800 01 HEAD-1.
- 016900 03 FILLER PIC X(5) VALUE "PCN: ".
- 017000 03 PCN-HD-1 PIC X(6) VALUE "ES050P".
- 017100 03 FILLER PIC X(14) VALUE " REPORT DATE: ".
- 017200 03 DAY-HD-1 PIC 99.
- 017300 03 FILLER PIC X VALUE SPACE.
- 017400 03 MTH-HD-1 PIC XXX.
- 017500 03 FILLER PIC X VALUE SPACE.
- 017600 03 YR-HD-1 PIC 99.
- 017700 03 FILLER PIC X(12) VALUE SPACE.
- 017800 03 FILLER PIC X(28) VALUE "UNITED STATES DEPARTMENT OF ".
- 017900 03 FILLER PIC X(36) VALUE "THE INTERIOR".
- 018000 03 FILLER PIC X(9) VALUE "PAGE NO: ".
- 018100 03 PG-HD-1 PIC ZZ,ZZZ.
- 018200 03 FILLER PIC X(7) VALUE SPACE.
- 018300 01 P-SPACE PIC X(132) VALUE SPACE.
- 018400 01 HEAD-2.
- 018500 03 FILLER PIC X(53) VALUE SPACE.
- 018600 03 FILLER PIC X(25) VALUE "BUREAU OF LAND MANAGEMENT".
- 018700 03 FILLER PIC X(54) VALUE SPACE.
- 018800 01 HEAD-3.
- 018900 03 FILLER PIC X(07) VALUE "STATE: ".
- 019000 03 ST-HD-3 PIC XX.
- 019100 03 FILLER PIC X VALUE SPACE.
- 019200 03 SN-HD-3 PIC X(12).
- 019300 03 FILLER PIC X(08) VALUE " DIST: ".
- 019400 03 DS-HD-3 PIC XX.
- 019500 03 FILLER PIC X VALUE SPACE.
- 019600 03 DN-HD-3 PIC X(15).
- 019700 03 FILLER PIC X(08) VALUE " RA: ".
- 019800 03 RA-HD-3 PIC XX.
- 019900 03 FILLER PIC X VALUE SPACE.
- 020000 03 RAN-HD-3 PIC X(15).
- 020100 03 FILLER PIC X(6) VALUE " PU: ".
- 020200 03 PS-HD-3 PIC 99.
- 020300 03 FILLER PIC X VALUE SPACE.
- 020400 03 PN-HD-3 PIC X(17).
- 020500 03 FILLER PIC X(13) VALUE " ALLOTMENT: ".
- 020600 03 AN-HD-3 PIC 9999 VALUE ZERO.
- 020700 03 FILLER PIC X VALUE SPACE.
- 020800 03 APS-HD-3 PIC 99 VALUE ZERO.
- 020900 03 FILLER PIC X(14) VALUE SPACE.
- 021000 01 HEAD-4.
- 021100 03 FILLER PIC X(54) VALUE SPACE.
- 021200 03 FILLER PIC X(23) VALUE "VEGETATION SWAT SUMMARY".
- 021300 03 FILLER PIC X(55) VALUE SPACE.
- 021400 01 HEAD-5.
- 021500 03 FILLER PIC X(30) VALUE "SWA TRN PLANT TYP ".
- 021600 03 FILLER PIC X(30) VALUE "P L A N T S W / I A C R E ".
- 021700 03 FILLER PIC X(30) VALUE " GRAMS & PROD WG".
- 021800 03 FILLER PIC X(30) VALUE "T TOTAL AVERAGE WEIG".
- 021900 03 FILLER PIC X(12) VALUE "HTED-AVERAGE".
- 022000 01 HEAD-6.
- 022100 03 FILLER PIC X(30) VALUE " B Y F O".
- 022200 03 FILLER PIC X(30) VALUE " R M C L A S S & A G E C L".
- 022300 03 FILLER PIC X(30) VALUE " A S S BY HT-CLS-CD ".
- 022400 03 FILLER PIC X(30) VALUE " PLANTS HGT CRWN AVAI".
- 022500 03 FILLER PIC X(12) VALUE "L UTIL PHENO".
- 022600 01 HEAD-7.
- 022700 03 FILLER PIC X(30) VALUE " 1 S ".
- 022800 03 FILLER PIC X(30) VALUE "2 P 3 Y 4 M 5 O 6 ".
- 022900 03 FILLER PIC X(30) VALUE "D R (1) (2) (3)".
- 023000 03 FILLER PIC X(42) VALUE " (4)".
- 023100 01 DET-1.
- 023200 03 SWA-P PIC X(4).
- 023300 03 FILLER PIC X.
- 023400 03 TRN-P PIC 99.
- 023500 03 FILLER PIC X.
- 023600 03 SPECIES-CD-P PIC X(7).
- 023700 03 FILLER PIC X.
- 023800 03 SPECIES-TYPE-P PIC X.
- 023900 03 PFC-P OCCURS 6 TIMES.
- 024000 05 FILLER PIC XX.
- 024100 05 PLANTS-FORM-CLS-P PIC Z(5).
- 024200 03 FILLER PIC X(8) VALUE SPACE.
- 024300 03 GHC-P OCCURS 4 TIMES.
- 024400 05 FILLER PIC XX.
- 024500 05 GRAMS-HGT-CLS-P PIC Z(5).
- 024600 03 FILLER PIC XXX VALUE SPACE.
- 024700 03 TOT-PLANTS-P PIC Z(5).
- 024800 03 FILLER PIC XX.
- 024900 03 AVG-HGT-P PIC ZZZ.9.
- 025000 03 FILLER PIC X.
- 025100 03 AVG-CROWN-P PIC ZZ.9.
- 025200 03 FILLER PIC XX.
- 025300 03 WTD-AVG-AVAIL-P PIC 999.
- 025400 03 FILLER PIC XXX.
- 025500 03 WTD-AVG-UTIL-P PIC 999.
- 025600 03 FILLER PIC XXX.
- 025700 03 WTD-AVG-PHNO-P PIC 9.
- 025800 03 FILLER PIC XX.
- 025900 01 DET-2.
- 026000 03 FILLER PIC X(19).
- 026100 03 PAC-P OCCURS 7 TIMES.
- 026200 05 FILLER PIC XX.
- 026300 05 PLANTS-AGE-CLS-P PIC Z(5).
- 026400 03 FILLER PIC X VALUE SPACE.
- 026500 03 PHC-P OCCURS 4 TIMES.
- 026600 05 FILLER PIC XX.
- 026700 05 PROD-HGT-CLS-P PIC Z(5).
- 026800 03 FILLER PIC X(35) VALUE SPACE.
- 026900 01 DISP-RK8.
- 027000 03 DRK8-1 PIC X(21).
- 027100 03 DRK8-2 PIC X(65).
- 027200 03 DRK8-3 PIC X(64).
- 027300 COPY DBSTATUS OF TPCOBOLIB.
- 027400 COPY REC-KEY0 IN LIBRARY1.
- 027500 COPY REC-KEY5 IN LIBRARY1.
- 027600 COPY REC-KEY6 IN LIBRARY1.
- 027700 COPY REC-KEY7 IN LIBRARY1.
- 027800 COPY REC-KEY8 IN LIBRARY1.
- 027900 01 PLANT-TOT-TABLE.
- 028000 03 TOT-PLANTS PIC 999 OCCURS 99 TIMES.
- 028100 01 PLANT-CAL-TABLE.
- 028200 03 PC-TAB OCCURS 10 TIMES.
- 028300 05 TK-TAB PIC 99.
- 028400 05 CHAR-TAB PIC 999.
- 028500 01 PLANT-CAL-HLD.
- 028600 03 PC-SUB PIC 99.
- 028700 03 PC-PCT PIC 999V99.
- 028800 03 PC-CHAR PIC 999.
- 028900 03 PC-NOT-CHAR PIC 999.
- 029000 03 PC-TOT-PLANTS PIC 999.
- 029100 03 PC-TABKEY PIC 99.
- 029200 01 PROD-WGT-HLD.
- 029300 03 PW-PLOT-TOT PIC 99.
- 029400 03 PW-GRAMS PIC 9(7).
- 029500 03 PW-GRAMS-HLD PIC 9(7).
- 029600 03 PW-LBS-ACRE PIC 9(8).
- 029700 03 PW-SIZE PIC 999V99.
- 029800 03 PW-WUAF PIC 999.
- 029900 03 PW-WAUF PIC 999V99.
- 030000 03 PW-GRP-PROD.
- 030100 05 PW-PROD PIC 9(5) OCCURS 4 TIMES.
- 030200 01 UTIL-PHENO-TABLE.
- 030300 03 UP-TAB OCCURS 40 TIMES.
- 030400 05 UTIL-TB PIC 9.
- 030500 05 PHNO-TB PIC 9.
- 030600 05 MID-PT-TB PIC 999.
- 030700 05 GRAM-UP-TB PIC 9(5).
- 030800 05 AVAIL-TB PIC 9V99.
- 030900 05 PHNO-TAB PIC 9.
- 031000 01 UTIL-PHENO-HLD.
- 031100 03 UTIL-GRAMS-TOT PIC 9(8).
- 031200 03 UTIL-MID-POINT-TOT PIC 9(4)V999.
- 031300 03 UTIL-MP-ACUM PIC 9(4)V999.
- 031400 03 PHNO-GRAMS-TOT PIC 9(8)V99.
- 031500 03 PHNO-ACUM PIC 9(8).
- 031600 03 PHNO-AVG-TOT PIC 9(8).
- 031700 03 PHNO-AVG-PLOT-TOT PIC 9(8).
- 031800 03 PHNO-HLD PIC 9.
- 031900 03 UTIL-AVG PIC 9V99.
- 032000 03 UTIL-AVG-RD REDEFINES UTIL-AVG PIC 999.
- 032100 03 UTIL-AVG-DEC-RD REDEFINES UTIL-AVG.
- 032200 05 UTIL-AVG-1 PIC 9.
- 032300 05 UTIL-AVG-2 PIC 99.
- 032400 03 MID-PT-HLD PIC 999.
- 032500 03 MID-PT-HLD-RD REDEFINES MID-PT-HLD PIC 9V99.
- 032600 03 UTIL-HLD PIC 9.
- 032700 03 PHNO-AVG PIC 9.
- 032800 03 PHNO-PLOT-AVG PIC 9.
- 032900 03 PHNO-PLOT-TOT PIC 99.
- 033000 01 HT-CLS-TABLE.
- 033100 03 HT-CLS-TAB.
- 033200 05 GRAM-HC-TB-RD.
- 033300 07 GRAM-HC-TB PIC 9(5) OCCURS 4.
- 033400 05 PLOT-TOT-HC-TB PIC 99 OCCURS 4 TIMES.
- 033500 01 FORM-CLS-TABLE.
- 033600 03 FORM-CLS-TAB.
- 033700 05 PLOT-TOT-FC-TB PIC 999 OCCURS 6 TIMES.
- 033800 05 PLANT-TOT-FC-TB PIC 999 OCCURS 6 TIMES.
- 033900 05 PIA-FC-RD.
- 034000 07 PIA-FC PIC 9(5) OCCURS 6 TIMES.
- 034100 01 AGE-CLS-TABLE.
- 034200 03 AGE-CLS-TAB.
- 034300 05 PLOT-TOT-AC-TB PIC 999 OCCURS 8 TIMES.
- 034400 05 PLANT-TOT-AC-TB PIC 999 OCCURS 8 TIMES.
- 034500 05 PIA-AC-RD.
- 034600 07 PIA-AC PIC 9(5) OCCURS 8 TIMES.
- 034700 05 PIA-AC-RD2 REDEFINES PIA-AC-RD.
- 034800 07 PIA-AC2 PIC X(35).
- 034900 07 PIA-AC3 PIC 9(5).
- 035000 01 FORM-AGE-HOLD.
- 035100 03 PLOT-NUM-FAH PIC 99.
- 035200 03 ACRE-FRAC-FAH PIC 999.
- 035300 03 TYPE-SP-FAH PIC X.
- 035400 03 ACRE-SF-TOT PIC 9(6)V9.
- 035500 03 PLOT-SAMP-SZ-FAH PIC 999V99.
- 035600 03 PLANTS-ACUM PIC 9(8).
- 035700 01 AVG-HGT-CROWN-AVL.
- 035800 03 PLANT-TOT-HGT PIC 999.
- 035900 03 PLANT-TOT-CROWN PIC 999.
- 036000 03 PLANT-TOT-AVAIL PIC 999.
- 036100 03 AVG-HGT-SUM PIC 9(6)V9.
- 036200 03 AVG-HGT-TOT PIC 9(6)V9.
- 036300 03 AVG-HGT PIC 999V9.
- 036400 03 AVG-CROWN-SUM PIC 9(5)V9.
- 036500 03 AVG-CROWN-TOT PIC 9(5)V9.
- 036600 03 AVG-CROWN PIC 99V9.
- 036700 03 AVG-AVAIL-SUM PIC 9(6)V99.
- 036800 03 GRAM-UP-TB-HLD PIC 9(5).
- 036900 03 AVG-AVAIL-PCT PIC 9V99.
- 037000 03 AVG-AVAIL-TOT PIC 9(6)V99.
- 037100 03 AVG-AVAIL PIC 999V99.
- 037200 03 AVG-AVAIL-RD REDEFINES AVG-AVAIL.
- 037300 05 AVG-AV-00 PIC 99.
- 037400 05 AVG-AV-PCT PIC 999.
- 037500 01 MID-POINT-TABLE.
- 037600 03 MPT PIC 9(10) VALUE 1030507090.
- 037700 03 MID-PT REDEFINES MPT PIC 99 OCCURS 5.
- 037800 01 DIS-HD1.
- 037900 03 FILLER PIC X(30) VALUE "AUDIT TRAIL FOR SWAT-SPECIES: ".
- 038000 03 DIS-SS.
- 038100 05 DIS-ST PIC XX.
- 038200 05 FILLER PIC X.
- 038300 05 DIS-SWAT PIC X(6).
- 038400 05 FILLER PIC X.
- 038500 05 DIS-SP1 PIC X(7).
- 038600 05 DIS-SP2 PIC X(7).
- 038700 05 DIS-SP3 PIC X(7).
- 038800 01 DIS-HD2.
- 038900 03 FILLER PIC X(30) VALUE "TOT-PLANTS PLOT-SIZE PLOT-TOT".
- 039000 03 FILLER PIC X(30) VALUE "-BY-HTC WGT BY HTC ----------".
- 039100 03 FILLER PIC X(30) VALUE "-- PLOT-TOT BY AGE ----------".
- 039200 03 FILLER PIC X(30) VALUE "----- PLOT-TOT BY FORM ------".
- 039300 01 DIS-HD3.
- 039400 03 FILLER PIC X(30) VALUE "TOT-HGT AVG-HGT-TOT TOT-CRN A".
- 039500 03 FILLER PIC X(30) VALUE "VG-CRN-TOT TOT-AVAIL AVG-AVAI".
- 039600 03 FILLER PIC X(30) VALUE "L-TOT UTIL-AVG WGTD-AVG-UTIL-F".
- 039700 03 FILLER PIC X(30) VALUE "AC ACRE-FRAC-FAH ACRE-SF-TOT ".
- 039800 01 DIS-DT1.
- 039900 03 FILLER PIC XXX.
- 040000 03 TP-DD PIC 999.
- 040100 03 FILLER PIC X(5).
- 040200 03 PS1-DD PIC 9.
- 040300 03 FILLER PIC X.
- 040400 03 PS2-DD PIC 999.99.
- 040500 03 FILLER PIC X(3).
- 040600 03 PT-DD-TB OCCURS 4 TIMES.
- 040700 05 PT-DD PIC 999.
- 040800 05 FILLER PIC X.
- 040900 03 FILLER PIC X.
- 041000 03 WGT-DD-TB OCCURS 4 TIMES.
- 041100 05 WGT-DD PIC 9(5).
- 041200 05 FILLER PIC X.
- 041300 03 FILLER PIC X.
- 041400 03 PT-AC-DD-TB OCCURS 7 TIMES.
- 041500 05 PT-AC-DD PIC 999.
- 041600 05 FILLER PIC X.
- 041700 03 FILLER PIC X.
- 041800 03 PT-FC-DD-TB OCCURS 6 TIMES.
- 041900 05 PT-FC-DD PIC 999.
- 042000 05 FILLER PIC X.
- 042100 01 DIS-DT2.
- 042200 03 FILLER PIC XX.
- 042300 03 TH-DD PIC 999.
- 042400 03 FILLER PIC XXXX.
- 042500 03 AHT-DD PIC 9(6).9.
- 042600 03 FILLER PIC XXXXXX.
- 042700 03 TC-DD PIC 999.
- 042800 03 FILLER PIC X(5).
- 042900 03 ACT-DD PIC 9(5).9.
- 043000 03 FILLER PIC X(7).
- 043100 03 TA-DD PIC 999.
- 043200 03 FILLER PIC X(8).
- 043300 03 AAT-DD PIC 9(6).
- 043400 03 FILLER PIC X(6).
- 043500 03 UA-DD PIC 999.
- 043600 03 FILLER PIC X(11).
- 043700 03 WAUF-DD PIC 999.
- 043800 03 FILLER PIC X(12).
- 043900 03 AFF-DD PIC 999.
- 044000 03 FILLER PIC X(7).
- 044100 03 AST-DD PIC 9(6).9.
- 044200 01 SEL-ST-AUDIT-SWAT-SPECIES.
- 044300 03 SEL-ST PIC XX VALUE "NM".
- 044400 03 FILLER PIC X VALUE SPACE.
- 044500 03 AUDIT-SWAT PIC X(6) VALUE "Z00101".
- 044600 03 FILLER PIC X VALUE SPACE.
- 044700 03 AUDIT-SPEC1 PIC X(7) VALUE "ERPU8 ".
- 044800 03 AUDIT-SPEC2 PIC X(7) VALUE "GUSA2 ".
- 044900 03 AUDIT-SPEC3 PIC X(7) VALUE "HIMU2 ".
- 045000 01 DIS-REC.
- 045100 03 PAR-DR PIC 999.
- 045200 03 FILLER PIC XX.
- 045300 03 FAN-DR PIC X(25).
- 045400 03 PR1-DR.
- 045500 05 FILLER PIC X.
- 045600 05 SB1-DR PIC 99.
- 045700 05 FILLER PIC XX.
- 045800 03 FA-DR PIC 9(8).
- 045900 03 FA1-DR REDEFINES FA-DR PIC 9(6).9.
- 046000 03 FA2-DR REDEFINES FA-DR PIC 9(5).99.
- 046100 03 FA3-DR REDEFINES FA-DR PIC 9(4).999.
- 046200 03 FILLER PIC XX.
- 046300 03 SGN-DR PIC X.
- 046400 03 FILLER PIC XX.
- 046500 03 FB-DR PIC 9(8).
- 046600 03 FB1-DR REDEFINES FB-DR PIC 9(6).9.
- 046700 03 FB2-DR REDEFINES FB-DR PIC 9(5).99.
- 046800 03 FB3-DR REDEFINES FB-DR PIC 9(4).999.
- 046900 03 FBS-DR REDEFINES FB-DR PIC X(8).
- 047000 03 FILLER PIC XX.
- 047100 03 FBN-DR PIC X(25).
- 047200 03 PR2-DR.
- 047300 05 FILLER PIC X.
- 047400 05 SB2-DR PIC 99.
- 047500 05 FILLER PIC XX.
- 047600 03 FILLER-DR PIC XXX VALUE " = ".
- 047700 03 FC-DR PIC 9(8).
- 047800 03 FC1-DR REDEFINES FC-DR PIC 9(6).9.
- 047900 03 FC2-DR REDEFINES FC-DR PIC 9(5).99.
- 048000 03 FC3-DR REDEFINES FC-DR PIC 9(4).999.
- 048100 03 FILLER PIC XX.
- 048200 03 FCN-DR PIC X(25).
- 048300 03 PR3-DR.
- 048400 05 FILLER PIC X.
- 048500 05 SB3-DR PIC 99.
- 048600 05 FILLER PIC XX.
- 048700 PROCEDURE DIVISION.
- 048800 010-HOUSEKEEPING.
- 048900 MOVE SEL-ST-AUDIT-SWAT-SPECIES TO DIS-SS.
- 049000 DISPLAY DIS-HD1.
- 049100 ACCEPT HLD-DT FROM DATE.
- 049200 MOVE YR-DT TO YR-HD-1.
- 049300 MOVE DY-DT TO DAY-HD-1.
- 049400 MOVE MON-T (MO-DT) TO MTH-HD-1.
- 049500 OPEN INPUT FILE-D7,
- 049600 OUTPUT FILE-D8, FILE-P1.
- 049700 READY DIC-DE.
- 049800 MOVE SPACE TO DIS-REC.
- 049900 INITIALIZE PLANT-TOT-TABLE, PLANT-CAL-TABLE,
- 050000 PLANT-CAL-HLD, UTIL-PHENO-TABLE,
- 050100 UTIL-PHENO-HLD, HT-CLS-TABLE, FORM-CLS-TABLE,
- 050200 AGE-CLS-TABLE, FORM-AGE-HOLD, AVG-HGT-CROWN-AVL
- 050300 FC-AC-CNTL PROD-WGT-HLD DIS-DT1 DIS-DT2 DIS-REC.
- 050400 PERFORM 020-RD-IN THRU 030-EXIT.
- 050500 GO TO 040-LOAD-REC.
- 050600 020-RD-IN.
- 050700 READ FILE-D7 AT END
- 050800 MOVE 1 TO END-SW GO TO 058-CHK-CAL-SW.
- 050900 IF SPECIES-D7 = "ZZBAREN"
- 051000 MOVE "BARREN " TO SPECIES-D7.
- 051100 IF (SPECIES-D7 = "BARREN ") AND
- 051200 (SWAT-CNTL-D7 = SWAT-CNTL-HLD)
- 051300 GO TO 020-RD-IN.
- 051400 IF (SPECIES-D7 = "BARREN ") AND
- 051500 (SWAT-CNTL-D7 = SWAT-CNTL-BARREN)
- 051600 GO TO 020-RD-IN.
- 051700 IF SPECIES-D7 = "BARREN "
- 051800 MOVE SWAT-CNTL-D7 TO SWAT-CNTL-BARREN
- 051900 INITIALIZE REC-KEY8
- 052000 MOVE 8 TO REC-KEY-RK8
- 052100 MOVE SWAT-CNTL-BARREN TO SWAT-RK8
- 052200 MOVE ZERO TO PLANT-TYP-RK8
- 052300 MOVE "BARREN " TO SPECIES-KEY-RK8
- 052400 MOVE REC-KEY8 TO FDR-D8
- 052500 MOVE ZERO TO PLOTS-CHRZ-D8
- 052600 WRITE FDR-D8
- 052700 ADD 1 TO REC-CNT
- 052800 GO TO 020-RD-IN.
- 052900* IF SPEC-TEST-CNT > 002
- 053000* MOVE 1 TO END-SW GO TO 058-CHK-CAL-SW.
- 053100* IF ST-D7 NOT = SEL-ST GO TO 020-RD-IN.
- 053200 IF (REC-KEY-D7 = 0) AND (SPECIES-D7 = SPACE)
- 053300 AND (SD-D7 = "NM03")
- 053400 MOVE 03 TO PLOT-TOT-CHRZ-D7.
- 053500 IF (REC-KEY-D7 = 0) AND (SPECIES-D7 = SPACE)
- 053600 AND (CHRZ-SW = 2)
- 053700 MOVE ZERO TO CHRZ-SW
- 053800 MOVE PLOT-TOT-CHRZ-D7 TO PLOTS-CHRZ-HLD
- 053900 GO TO 020-RD-IN.
- 054000 IF (REC-KEY-D7 = 0) AND (SPECIES-D7 = SPACE)
- 054100 MOVE 1 TO CHRZ-SW
- 054200 MOVE PLOT-TOT-CHRZ-D7 TO PLOTS-CHRZ-HLD-2
- 054300 GO TO 020-RD-IN.
- 054400 MOVE SORT-CNTL TO KEYS-IN.
- 054500 INITIALIZE FAC-HLD.
- 054600 020-EXIT-RD.
- 054700 GO TO 030-MV-IN.
- 054800 025-CK-SUM.
- 054900 IF RK-SW = 1
- 055000 MOVE ZERO TO RK-SW
- 055100 PERFORM 030-MV-IN
- 055200 GO TO 055-PASS.
- 055300 GO TO 460-BUILD-SUMMARY.
- 055400 030-MV-IN.
- 055500 MOVE SWAT-CNTL-D7 TO SWAT-CNTL-HLD SC-FAC.
- 055600 MOVE REC-KEY-D7 TO REC-KEY-SCH RK-FAC.
- 055700 MOVE REC-TYP-D7 TO REC-TYP-SCH.
- 055800 MOVE FMT-NUM-D7 TO FMT-NUM-SCH.
- 055900 MOVE FMT-CD-D7 TO FMT-CD-SCH.
- 056000 MOVE SPECIES-D7 TO SPECIES-CD-SCH SPEC-FAC.
- 056100 MOVE KEYS-IN TO KEYS-SCH.
- 056200 MOVE ALLOT-NUM-SCH TO AN-HD-3.
- 056300 MOVE PASTURE-NUM-SCH TO APS-HD-3.
- 056400 MOVE SK-0 TO FAPN-FAC.
- 056500 030-EXIT.
- 056600 EXIT.
- 056700 040-LOAD-REC.
- 056800 IF REC-KEY-D7 = 0 OR 6 OR 7
- 056900 MOVE FDR-D7 TO REC-KEY0 REC-KEY6 REC-KEY7.
- 057000 IF REC-KEY-D7 = 5
- 057100 MOVE FDR-D7 TO REC-KEY5.
- 057200 050-CNTL-CHK.
- 057300 IF SWAT-CNTL-D7 NOT EQUAL SWAT-CNTL-HLD
- 057400* ADD 1 TO SPEC-TEST-CNT
- 057500 MOVE 1 TO SWAT-SW
- 057600 GO TO 058-CHK-CAL-SW.
- 057700 IF SPECIES-D7 NOT EQUAL SPECIES-CD-SCH
- 057800* ADD 1 TO SPEC-TEST-CNT
- 057900 MOVE 1 TO SPEC-SW
- 058000 GO TO 058-CHK-CAL-SW.
- 058100 IF REC-KEY-D7 NOT EQUAL REC-KEY-SCH
- 058200 MOVE 1 TO RK-SW
- 058300 GO TO 060-CK-LST.
- 058400 IF (REC-KEY-D7 = 0) AND
- 058500 (PN-S-0-IN NOT EQUAL PN-S-0)
- 058600 MOVE 1 TO RK-SW
- 058700 GO TO 060-CK-LST.
- 058800 055-PASS.
- 058900 IF (SWAT-SCH = AUDIT-SWAT) AND (SEL-ST = ADST-CD-SCH)
- 059000 AND (SPECIES-CD-SCH = AUDIT-SPEC1 OR AUDIT-SPEC2
- 059100 OR AUDIT-SPEC3)
- 059200 DISPLAY FDR-D7
- 059300 MOVE 1 TO AUDIT ELSE MOVE ZERO TO AUDIT.
- 059400 IF REC-KEY-D7 = 0
- 059500 GO TO 100-REC-0-PROC.
- 059600 IF REC-KEY-D7 = 5
- 059700 GO TO 200-REC-5-PROC.
- 059800 IF REC-KEY-D7 = 6
- 059900 GO TO 300-REC-6-PROC.
- 060000 IF REC-KEY-D7 = 7
- 060100 GO TO 400-REC-7-PROC.
- 060200 DISPLAY "BAD REC-KEY".
- 060300 STOP RUN.
- 060400 058-CHK-CAL-SW.
- 060500 IF (REC-KEY-SCH = 0)
- 060600 OR (SPEC-SW = 1)
- 060700 OR (SWAT-SW = 1)
- 060800 PERFORM 110-CAL-0-PROC THRU 110-EXIT
- 060900 PERFORM 210-CAL-5-PROC THRU 210-EXIT
- 061000 PERFORM 310-CAL-6-PROC THRU 310-EXIT.
- 061100 IF REC-KEY-SCH = 5
- 061200 PERFORM 210-CAL-5-PROC THRU 210-EXIT
- 061300 PERFORM 310-CAL-6-PROC THRU 310-EXIT.
- 061400 IF REC-KEY-SCH = 6
- 061500 PERFORM 310-CAL-6-PROC THRU 310-EXIT.
- 061600 GO TO 410-CAL-7-PROC.
- 061700 060-CK-LST.
- 061800 IF REC-KEY-SCH = 0
- 061900 PERFORM 110-CAL-0-PROC THRU 110-EXIT
- 062000 GO TO 025-CK-SUM.
- 062100 IF REC-KEY-SCH = 5
- 062200 PERFORM 210-CAL-5-PROC THRU 210-EXIT
- 062300 GO TO 025-CK-SUM.
- 062400 IF REC-KEY-SCH = 6
- 062500 PERFORM 310-CAL-6-PROC THRU 310-EXIT
- 062600 GO TO 025-CK-SUM.
- 062700 IF REC-KEY-SCH = 7
- 062800 DISPLAY "BAD SEQUENCE "
- 062900 STOP RUN.
- 063000 100-REC-0-PROC.
- 063100 ADD 1 TO SUB1.
- 063200 MOVE CHARZD-NUM-RK0 TO CHAR-TAB (SUB1).
- 063300 MOVE PLANT-TYP-RK0 TO TYPE-SPEC-HLD.
- 063400 MOVE PLANT-CD-RK0 TO SPEC-HLD.
- 063500 MOVE TAB-KEY-0 TO TK-TAB (SUB1).
- 063600 ADD CHARZD-NUM-RK0 TO PC-CHAR.
- 063700 ADD CHARZD-NOT-NUM-RK0 TO PC-NOT-CHAR.
- 063800 PERFORM 020-RD-IN.
- 063900 GO TO 040-LOAD-REC.
- 064000 110-CAL-0-PROC.
- 064100 MOVE ZERO TO SUB1.
- 064200 ADD PC-CHAR PC-NOT-CHAR GIVING PC-TOT-PLANTS.
- 064300 IF AUDIT = 1
- 064400 MOVE 110 TO PAR-DR
- 064500 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 064600 MOVE "PC-CHAR" TO FAN-DR
- 064700 MOVE PC-CHAR TO FA-DR
- 064800 MOVE "+" TO SGN-DR
- 064900 MOVE " = " TO FILLER-DR
- 065000 MOVE PC-NOT-CHAR TO FB-DR
- 065100 MOVE "PC-NOT-CHAR" TO FBN-DR
- 065200 MOVE PC-TOT-PLANTS TO FC-DR
- 065300 MOVE "PC-TOT-PLANTS" TO FCN-DR
- 065400 DISPLAY P-SPACE
- 065500 DISPLAY DIS-REC.
- 065600 120-LP-TB.
- 065700 ADD 1 TO SUB1.
- 065800 IF TK-TAB (SUB1) = ZERO
- 065900 MOVE ZERO TO SUB1
- 066000 INITIALIZE PLANT-CAL-TABLE PLANT-CAL-HLD
- 066100 GO TO 110-EXIT.
- 066200 MOVE TK-TAB (SUB1) TO PC-TABKEY.
- 066300 DIVIDE PC-CHAR INTO CHAR-TAB (SUB1)
- 066400 GIVING PC-PCT.
- 066500 IF AUDIT = 1
- 066600 MOVE 120 TO PAR-DR
- 066700 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 066800 MOVE "PC-CHAR" TO FAN-DR
- 066900 MOVE PC-CHAR TO FA-DR
- 067000 MOVE "/" TO SGN-DR
- 067100 MOVE CHAR-TAB (SUB1) TO FB-DR
- 067200 MOVE "CHAR-TAB (SUB1)" TO FBN-DR
- 067300 MOVE PC-PCT TO FC2-DR
- 067400 MOVE "PC-PCT" TO FCN-DR
- 067500 MOVE "( ) " TO PR2-DR
- 067600 MOVE SUB1 TO SB2-DR
- 067700 DISPLAY P-SPACE
- 067800 DISPLAY DIS-REC.
- 067900 MULTIPLY PC-PCT BY PC-TOT-PLANTS
- 068000 GIVING TOT-PLANTS (PC-TABKEY) ROUNDED.
- 068100 IF AUDIT = 1
- 068200 MOVE 121 TO PAR-DR
- 068300 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 068400 MOVE "PC-PCT" TO FAN-DR
- 068500 MOVE PC-PCT TO FA2-DR
- 068600 MOVE "X" TO SGN-DR
- 068700 MOVE PC-TOT-PLANTS TO FB-DR
- 068800 MOVE "PC-TOT-PLANTS" TO FBN-DR
- 068900 MOVE TOT-PLANTS (PC-TABKEY) TO FC-DR
- 069000 MOVE "TOT-PLANTS (PC-TABKEY)" TO FCN-DR
- 069100 MOVE "( ) " TO PR3-DR
- 069200 MOVE PC-TABKEY TO SB3-DR
- 069300 DISPLAY P-SPACE
- 069400 DISPLAY DIS-REC.
- 069500 ADD TOT-PLANTS (PC-TABKEY) TO PLANT-TOTAL.
- 069600 IF AUDIT = 1
- 069700 MOVE 122 TO PAR-DR
- 069800 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 069900 MOVE "TOT-PLANTS (PC-TABKEY)" TO FAN-DR
- 070000 MOVE TOT-PLANTS (PC-TABKEY) TO FA-DR
- 070100 MOVE "+" TO SGN-DR
- 070200 MOVE " = " TO FILLER-DR
- 070300 MOVE SPACE TO FBS-DR
- 070400 MOVE SPACE TO FBN-DR
- 070500 MOVE PLANT-TOTAL TO FC-DR
- 070600 MOVE "PLANT-TOTAL" TO FCN-DR
- 070700 MOVE "( ) " TO PR1-DR
- 070800 MOVE PC-TABKEY TO SB1-DR
- 070900 DISPLAY P-SPACE
- 071000 DISPLAY DIS-REC.
- 071100 GO TO 120-LP-TB.
- 071200 200-REC-5-PROC.
- 071300 MOVE PLANT-TYP-RK5 TO TYPE-SPEC-HLD.
- 071400 MOVE PLANT-CD-RK5 TO SPEC-HLD.
- 071500 MOVE ZERO TO SUB5.
- 071600 MOVE PLOT-SIZ-EST-RK5 TO PW-SIZE PLOT-SAMP-SZ-FAH.
- 071700 MOVE PLOT-TOT-NUM-RK5 TO PW-PLOT-TOT.
- 071800 MOVE HGT-CLS-CD-RK5 TO HC-HLD.
- 071900 IF HC-HLD < 1 OR > 4
- 072000 MOVE 1 TO HC-HLD.
- 072100 IF FMT-NUM-RK5 = 1 MOVE ZERO TO SUB6.
- 072200 IF FMT-NUM-RK5 = 2 MOVE 10 TO SUB6.
- 072300 IF FMT-NUM-RK5 = 3 MOVE 20 TO SUB6.
- 072400 IF FMT-NUM-RK5 = 4 MOVE 30 TO SUB6.
- 072500 205-LP-TB.
- 072600 IF SUB5 = 10 PERFORM 020-RD-IN GO TO 040-LOAD-REC.
- 072700 ADD 1 TO SUB5.
- 072800 ADD 1 TO SUB6.
- 072900* IF HRBG-PROD-WGT-RK5 (SUB5) > ZERO
- 073000* ADD HRBG-PROD-WGT-RK5 (SUB5) TO GRAM-UP-TB (SUB6)
- 073100* ADD HRBG-PROD-WGT-RK5 (SUB5) TO
- 073200* GRAM-HC-TB (HC-HLD).
- 073300* ADD 1 TO PLOT-TOT-HC-TB (HC-HLD).
- 073400* MOVE CLS-PLANT-UTIL-RK5 (SUB5) TO UTIL-HLD.
- 073500* MOVE PHNO-STG-RK5 (SUB5) TO PHNO-HLD.
- 073600* IF UTIL-TB (SUB6) = ZERO
- 073700* MOVE UTIL-HLD TO UTIL-TB (SUB6).
- 073800* IF PHNO-TB (SUB6) = ZERO
- 073900* MOVE PHNO-HLD TO PHNO-TB (SUB6).
- 074000* IF UTIL-HLD > ZERO
- 074100* MOVE MID-PT (UTIL-HLD) TO MID-PT-TB (SUB6)
- 074200* ELSE MOVE ZERO TO MID-PT-TB (SUB6).
- 074300* GO TO 205-LP-TB.
- 074400 MOVE CLS-PLANT-UTIL-RK5 (SUB5) TO UTIL-HLD.
- 074500 MOVE PHNO-STG-RK5 (SUB5) TO PHNO-HLD.
- 074600 IF (PHNO-STG-RK5 (SUB5) > ZERO)
- 074700 ADD 1 TO PHNO-PLOT-TOT
- 074800 MOVE PHNO-HLD TO PHNO-TAB (SUB6) .
- 074900 IF (HRBG-PROD-WGT-RK5 (SUB5) > ZERO)
- 075000 MOVE 1 TO AVAIL-SW
- 075100 ADD HRBG-PROD-WGT-RK5 (SUB5) TO
- 075200 GRAM-HC-TB (HC-HLD).
- 075300 IF (HRBG-PROD-WGT-RK5 (SUB5) > ZERO)
- 075400 AND (PHNO-STG-RK5 (SUB5) > ZERO)
- 075500 ADD HRBG-PROD-WGT-RK5 (SUB5) TO GRAM-UP-TB (SUB6)
- 075600 MOVE UTIL-HLD TO UTIL-TB (SUB6)
- 075700 MOVE PHNO-HLD TO PHNO-TB (SUB6)
- 075800 ELSE GO TO 205-LP-TB.
- 075900 IF UTIL-HLD > ZERO
- 076000 MOVE MID-PT (UTIL-HLD) TO MID-PT-TB (SUB6)
- 076100 ELSE MOVE ZERO TO MID-PT-TB (SUB6).
- 076200 MOVE ZERO TO AVAIL-TB (SUB6).
- 076300 IF CLS-PLANT-AVAIL-RK5 (SUB5) = " " OR "A"
- 076400 MOVE 1.00 TO AVAIL-TB (SUB6).
- 076500* IF CLS-PLANT-AVAIL-RK5 (SUB5) = "P"
- 076600* MOVE 0.50 TO AVAIL-TB (SUB6).
- 076700 IF CLS-PLANT-AVAIL-RK5 (SUB5) = "U"
- 076800 MOVE 0.00 TO AVAIL-TB (SUB6).
- 076900 IF CLS-PLANT-AVAIL-RK5 (SUB5) = "P"
- 077000 MOVE 0.75 TO AVAIL-TB (SUB6).
- 077100 IF CLS-PLANT-AVAIL-RK5 (SUB5) = "H"
- 077200 MOVE 0.50 TO AVAIL-TB (SUB6).
- 077300 IF CLS-PLANT-AVAIL-RK5 (SUB5) = "L"
- 077400 MOVE 0.25 TO AVAIL-TB (SUB6).
- 077500 GO TO 205-LP-TB.
- 077600 110-EXIT.
- 077700 EXIT.
- 077800 210-CAL-5-PROC.
- 077900 MOVE ZERO TO SUB6 UTIL-AVG PHNO-AVG.
- 078000 230-LP-TB.
- 078100 ADD 1 TO SUB6.
- 078200 IF SUB6 < 41
- 078300 GO TO 240-UTIL-PHENO.
- 078400 IF (PHNO-GRAMS-TOT > ZERO) AND (AVG-AVAIL-TOT > ZERO)
- 078500 DIVIDE PHNO-GRAMS-TOT INTO AVG-AVAIL-TOT
- 078600 GIVING AVG-AVAIL ROUNDED.
- 078700 IF PHNO-AVG-PLOT-TOT > ZERO
- 078800 DIVIDE PHNO-PLOT-TOT INTO PHNO-AVG-PLOT-TOT
- 078900 GIVING PHNO-PLOT-AVG ROUNDED.
- 079000 IF AUDIT = 1 GO TO 235-UP-DISPLAY.
- 079100 IF UTIL-MID-POINT-TOT > ZERO
- 079200 DIVIDE UTIL-GRAMS-TOT INTO UTIL-MID-POINT-TOT
- 079300 GIVING UTIL-AVG ROUNDED.
- 079400 IF PHNO-AVG-TOT > ZERO
- 079500 DIVIDE PHNO-GRAMS-TOT INTO PHNO-AVG-TOT
- 079600 GIVING PHNO-AVG ROUNDED.
- 079700 GO TO 245-CLEAR.
- 079800 235-UP-DISPLAY.
- 079900 IF (PHNO-GRAMS-TOT > ZERO) AND (AVG-AVAIL-TOT > ZERO)
- 080000 AND (AUDIT = 1)
- 080100 MOVE 229 TO PAR-DR
- 080200 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 080300 MOVE "PHNO-GRAMS-TOT" TO FAN-DR
- 080400 MOVE PHNO-GRAMS-TOT TO FA1-DR
- 080500 MOVE "/" TO SGN-DR
- 080600 MOVE AVG-AVAIL-TOT TO FB1-DR
- 080700 MOVE "AVG-AVAIL-TOT" TO FBN-DR
- 080800 MOVE AVG-AVAIL TO FC2-DR
- 080900 MOVE "AVG-AVAIL" TO FCN-DR
- 081000 DISPLAY P-SPACE
- 081100 DISPLAY DIS-REC.
- 081200 IF UTIL-MID-POINT-TOT > ZERO
- 081300 DIVIDE UTIL-GRAMS-TOT INTO UTIL-MID-POINT-TOT
- 081400 GIVING UTIL-AVG ROUNDED
- 081500 MOVE 230 TO PAR-DR
- 081600 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 081700 MOVE "UTIL-GRAMS-TOT" TO FAN-DR
- 081800 MOVE UTIL-GRAMS-TOT TO FA-DR
- 081900 MOVE "/" TO SGN-DR
- 082000 MOVE UTIL-MID-POINT-TOT TO FB3-DR
- 082100 MOVE "UTIL-MID-POINT-TOT" TO FBN-DR
- 082200 MOVE UTIL-AVG TO FC2-DR
- 082300 MOVE "UTIL-AVG" TO FCN-DR
- 082400 DISPLAY P-SPACE
- 082500 DISPLAY DIS-REC.
- 082600 IF PHNO-AVG-TOT > ZERO
- 082700 DIVIDE PHNO-GRAMS-TOT INTO PHNO-AVG-TOT
- 082800 GIVING PHNO-AVG ROUNDED
- 082900 MOVE 231 TO PAR-DR
- 083000 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 083100 MOVE "PHNO-GRAMS-TOT" TO FAN-DR
- 083200 MOVE PHNO-GRAMS-TOT TO FA-DR
- 083300 MOVE "/" TO SGN-DR
- 083400 MOVE PHNO-AVG-TOT TO FB-DR
- 083500 MOVE "PHNO-AVG-TOT" TO FBN-DR
- 083600 MOVE PHNO-AVG TO FC-DR
- 083700 MOVE "PHNO-AVG" TO FCN-DR
- 083800 DISPLAY P-SPACE
- 083900 DISPLAY DIS-REC
- 084000 GO TO 245-CLEAR.
- 084100 240-UTIL-PHENO.
- 084200 MOVE MID-PT-TB (SUB6) TO MID-PT-HLD.
- 084300 IF (GRAM-UP-TB (SUB6) > ZERO) AND (AUDIT = ZERO)
- 084400 AND (PHNO-TB (SUB6) > ZERO)
- 084500 ADD GRAM-UP-TB (SUB6) TO UTIL-GRAMS-TOT.
- 084600 IF (GRAM-UP-TB (SUB6) > ZERO) AND (AUDIT = 1)
- 084700 AND (PHNO-TB (SUB6) > ZERO)
- 084800 ADD GRAM-UP-TB (SUB6) TO UTIL-GRAMS-TOT
- 084900 MOVE 232 TO PAR-DR
- 085000 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 085100 MOVE "GRAM-UP-TAB (SUB6)" TO FAN-DR
- 085200 MOVE GRAM-UP-TB (SUB6) TO FA-DR
- 085300 MOVE "+" TO SGN-DR
- 085400 MOVE " = " TO FILLER-DR
- 085500 MOVE SPACE TO FBS-DR
- 085600 MOVE SPACE TO FBN-DR
- 085700 MOVE UTIL-GRAMS-TOT TO FC-DR
- 085800 MOVE "UTIL-GRAMS-TOT" TO FCN-DR
- 085900 MOVE "( ) " TO PR1-DR
- 086000 MOVE SUB6 TO SB1-DR
- 086100 DISPLAY P-SPACE
- 086200 DISPLAY DIS-REC.
- 086300 IF (MID-PT-TB (SUB6) > ZERO) AND
- 086400 (GRAM-UP-TB (SUB6) > ZERO)
- 086500 MULTIPLY MID-PT-HLD-RD BY GRAM-UP-TB (SUB6)
- 086600 GIVING UTIL-MP-ACUM
- 086700 ADD UTIL-MP-ACUM TO UTIL-MID-POINT-TOT.
- 086800 IF (MID-PT-TB (SUB6) > ZERO) AND
- 086900 (GRAM-UP-TB (SUB6) > ZERO)
- 087000 AND (AUDIT = 1)
- 087100 MOVE 233 TO PAR-DR
- 087200 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 087300 MOVE "MID-PT-HLD-RD" TO FAN-DR
- 087400 MOVE MID-PT-HLD-RD TO FA2-DR
- 087500 MOVE "X" TO SGN-DR
- 087600 MOVE GRAM-UP-TB (SUB6) TO FB-DR
- 087700 MOVE "GRAM-UP-TB (SUB6)" TO FBN-DR
- 087800 MOVE UTIL-MP-ACUM TO FC3-DR
- 087900 MOVE "UTIL-MP-ACUM" TO FCN-DR
- 088000 MOVE "( ) " TO PR2-DR
- 088100 MOVE SUB6 TO SB2-DR
- 088200 DISPLAY P-SPACE
- 088300 DISPLAY DIS-REC
- 088400 MOVE 234 TO PAR-DR
- 088500 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 088600 MOVE "UTIL-MP-ACUM" TO FAN-DR
- 088700 MOVE UTIL-MP-ACUM TO FA3-DR
- 088800 MOVE "+" TO SGN-DR
- 088900 MOVE " = " TO FILLER-DR
- 089000 MOVE SPACE TO FBS-DR
- 089100 MOVE SPACE TO FBN-DR
- 089200 MOVE UTIL-MID-POINT-TOT TO FC3-DR
- 089300 MOVE "UTIL-MID-POINT-TOT" TO FCN-DR
- 089400 DISPLAY P-SPACE
- 089500 DISPLAY DIS-REC.
- 089600 IF PHNO-TAB (SUB6) > ZERO
- 089700 ADD PHNO-TAB (SUB6) TO PHNO-AVG-PLOT-TOT.
- 089800 IF PHNO-TB (SUB6) > ZERO
- 089900 ADD GRAM-UP-TB (SUB6) TO PHNO-GRAMS-TOT.
- 090000 IF (PHNO-TB (SUB6) > ZERO) AND
- 090100 (GRAM-UP-TB (SUB6) > ZERO)
- 090200 MULTIPLY PHNO-TB (SUB6) BY GRAM-UP-TB (SUB6)
- 090300 GIVING PHNO-ACUM
- 090400 ADD PHNO-ACUM TO PHNO-AVG-TOT.
- 090500 IF (PHNO-TB (SUB6) > ZERO) AND
- 090600 (GRAM-UP-TB (SUB6) > ZERO) AND (AUDIT = 1)
- 090700 MOVE 235 TO PAR-DR
- 090800 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 090900 MOVE "PHNO-TB (SUB6)" TO FAN-DR
- 091000 MOVE PHNO-TB (SUB6) TO FA-DR
- 091100 MOVE "X" TO SGN-DR
- 091200 MOVE GRAM-UP-TB (SUB6) TO FB-DR
- 091300 MOVE "GRAM-UP-TB (SUB6)" TO FBN-DR
- 091400 MOVE PHNO-ACUM TO FC-DR
- 091500 MOVE "PHNO-ACUM" TO FCN-DR
- 091600 MOVE "( ) " TO PR2-DR
- 091700 MOVE SUB6 TO SB2-DR
- 091800 DISPLAY P-SPACE
- 091900 DISPLAY DIS-REC.
- 092000 IF (PHNO-TB (SUB6) > ZERO) AND
- 092100 (GRAM-UP-TB (SUB6) > ZERO)
- 092200 NEXT SENTENCE ELSE
- 092300 GO TO 230-LP-TB.
- 092400 MOVE AVAIL-TB (SUB6) TO AVG-AVAIL-PCT.
- 092500 MOVE GRAM-UP-TB (SUB6) TO GRAM-UP-TB-HLD.
- 092600 MULTIPLY AVG-AVAIL-PCT BY GRAM-UP-TB-HLD
- 092700 GIVING AVG-AVAIL-SUM.
- 092800 ADD AVG-AVAIL-SUM TO AVG-AVAIL-TOT.
- 092900 IF (AUDIT = 1)
- 093000 MOVE 236 TO PAR-DR
- 093100 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 093200 MOVE "AVAIL-TB (SUB6)" TO FAN-DR
- 093300 MOVE AVAIL-TB (SUB6) TO FA2-DR
- 093400 MOVE "X" TO SGN-DR
- 093500 MOVE GRAM-UP-TB (SUB6) TO FB1-DR
- 093600 MOVE "GRAM-UP-TB (SUB6)" TO FBN-DR
- 093700 MOVE AVG-AVAIL-SUM TO FC1-DR
- 093800 MOVE "AVG-AVAIL-SUM" TO FCN-DR
- 093900 MOVE "( ) " TO PR2-DR
- 094000 MOVE SUB6 TO SB2-DR
- 094100 DISPLAY P-SPACE
- 094200 DISPLAY DIS-REC.
- 094300 GO TO 230-LP-TB.
- 094400 245-CLEAR.
- 094500 INITIALIZE UTIL-PHENO-TABLE SUB5 SUB6.
- 094600 210-EXIT.
- 094700 EXIT.
- 094800 300-REC-6-PROC.
- 094900 MOVE PLANT-TYP-RK6 TO TYPE-SPEC-HLD.
- 095000 IF PLOT-SIZE-RK6 = 1
- 095100 MOVE 100 TO ACRE-FRAC-FAH ELSE
- 095200 MOVE 200 TO ACRE-FRAC-FAH.
- 095300 MOVE FORM-CLS-KEY-6 TO FC-KEY.
- 095400 IF PW-PLOT-TOT = ZERO MOVE 10 TO PW-PLOT-TOT.
- 095500 MOVE PLOTS-CHRZ-HLD TO PLOT-TOT-FC-TB (FC-KEY).
- 095600 IF FORM-CLS-KEY-6 < 1 OR > 5
- 095700 MOVE 6 TO FORM-CLS-KEY-6 FC-KEY.
- 095800 MOVE TOT-PLANTS (TAB-KEY-0) TO PLANT-TOT-HLD.
- 095900* IF FAC-IN NOT = FAC-HLD
- 096000* ADD 1 TO PLOT-TOT-FC-TB (FC-KEY).
- 096100 ADD PLANT-TOT-HLD TO PLANT-TOT-FC-TB (FC-KEY).
- 096200 IF AUDIT = 1
- 096300 MOVE 300 TO PAR-DR
- 096400 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 096500 MOVE "PLANT-TOT-HLD" TO FAN-DR
- 096600 MOVE PLANT-TOT-HLD TO FA-DR
- 096700 MOVE "+" TO SGN-DR
- 096800 MOVE " = " TO FILLER-DR
- 096900 MOVE SPACE TO FBS-DR
- 097000 MOVE SPACE TO FBN-DR
- 097100 MOVE PLANT-TOT-FC-TB (FC-KEY) TO FC-DR
- 097200 MOVE "PLANT-TOT-FC-TB (FC-KEY)" TO FCN-DR
- 097300 MOVE "( ) " TO PR3-DR
- 097400 MOVE FC-KEY TO SB3-DR
- 097500 DISPLAY P-SPACE
- 097600 DISPLAY DIS-REC.
- 097700 PERFORM 020-RD-IN.
- 097800 GO TO 040-LOAD-REC.
- 097900 310-CAL-6-PROC.
- 098000 MOVE ZERO TO SUB4.
- 098100 320-LP-TB.
- 098200 ADD 1 TO SUB4.
- 098300 IF SUB4 = 7
- 098400 MOVE ZERO TO SUB4
- 098500 GO TO 310-EXIT.
- 098600 IF (PLANT-TOT-FC-TB (SUB4) = ZERO)
- 098700 GO TO 320-LP-TB.
- 098800 IF TYPE-SPEC-HLD = "T" OR "S"
- 098900 MULTIPLY ACRE-FRAC-FAH BY PLANT-TOT-FC-TB (SUB4)
- 099000 GIVING PLANTS-ACUM
- 099100 DIVIDE PLOT-TOT-FC-TB (SUB4) INTO PLANTS-ACUM
- 099200 GIVING PIA-FC (SUB4) ROUNDED.
- 099300 IF (TYPE-SPEC-HLD = "T" OR "S")
- 099400 AND (AUDIT = 1)
- 099500 MOVE 320 TO PAR-DR
- 099600 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 099700 MOVE "ACRE-FRAC-FAH" TO FAN-DR
- 099800 MOVE ACRE-FRAC-FAH TO FA-DR
- 099900 MOVE "X" TO SGN-DR
- 100000 MOVE PLANT-TOT-FC-TB (SUB4) TO FB-DR
- 100100 MOVE "PLANT-TOT-FC-TB (SUB4)" TO FBN-DR
- 100200 MOVE PLANTS-ACUM TO FC-DR
- 100300 MOVE "PLANTS-ACUM" TO FCN-DR
- 100400 DISPLAY P-SPACE
- 100500 DISPLAY DIS-REC
- 100600 MOVE 320 TO PAR-DR
- 100700 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 100800 MOVE "PLOT-TOT-FC-TB (SUB4)" TO FAN-DR
- 100900 MOVE PLOT-TOT-FC-TB (SUB4) TO FA-DR
- 101000 MOVE "/" TO SGN-DR
- 101100 MOVE PLANTS-ACUM TO FB-DR
- 101200 MOVE "PLANTS-ACUM" TO FBN-DR
- 101300 MOVE PIA-FC (SUB4) TO FC-DR
- 101400 MOVE "PIA-FC (SUB4)" TO FCN-DR
- 101500 MOVE "( ) " TO PR1-DR
- 101600 MOVE SUB4 TO SB1-DR
- 101700 MOVE "( ) " TO PR3-DR
- 101800 MOVE SUB4 TO SB3-DR
- 101900 DISPLAY P-SPACE
- 102000 DISPLAY DIS-REC.
- 102100 IF (TYPE-SPEC-HLD = "G" OR "F")
- 102200 AND (PLOT-SAMP-SZ-FAH = ZERO)
- 102300 IF PLOT-SIZE-0 = 1 MOVE 435.60 TO PLOT-SAMP-SZ-FAH
- 102400 ELSE
- 102500 IF PLOT-SIZE-0 = 2 MOVE 217.80 TO PLOT-SAMP-SZ-FAH.
- 102600 IF TYPE-SPEC-HLD = "G" OR "F"
- 102700 MULTIPLY PLOT-TOT-FC-TB (SUB4) BY PLOT-SAMP-SZ-FAH
- 102800 GIVING ACRE-SF-TOT
- 102900 MULTIPLY 43560 BY PLANT-TOT-FC-TB (SUB4)
- 103000 GIVING PLANTS-ACUM
- 103100 DIVIDE ACRE-SF-TOT INTO PLANTS-ACUM
- 103200 GIVING PIA-FC (SUB4) ROUNDED.
- 103300 IF (TYPE-SPEC-HLD = "G" OR "F")
- 103400 AND (AUDIT = 1)
- 103500 MOVE 320 TO PAR-DR
- 103600 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 103700 MOVE "PLOT-TOT-FC-TB (SUB4)" TO FAN-DR
- 103800 MOVE PLOT-TOT-FC-TB (SUB4) TO FA-DR
- 103900 MOVE "X" TO SGN-DR
- 104000 MOVE PLOT-SAMP-SZ-FAH TO FB2-DR
- 104100 MOVE "PLOT-SAMP-SZ-FAH" TO FBN-DR
- 104200 MOVE ACRE-SF-TOT TO FC1-DR
- 104300 MOVE "ACRE-SF-TOT" TO FCN-DR
- 104400 MOVE "( ) " TO PR1-DR
- 104500 MOVE SUB4 TO SB1-DR
- 104600 DISPLAY P-SPACE
- 104700 DISPLAY DIS-REC
- 104800 MOVE 322 TO PAR-DR
- 104900 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 105000 MOVE "CONSTANT" TO FAN-DR
- 105100 MOVE 43560 TO FA-DR
- 105200 MOVE "X" TO SGN-DR
- 105300 MOVE PLANT-TOT-FC-TB (SUB4) TO FB-DR
- 105400 MOVE "PLANT-TOT-FC-TB (SUB4)" TO FBN-DR
- 105500 MOVE PLANTS-ACUM TO FC-DR
- 105600 MOVE "PLANTS-ACUM" TO FCN-DR
- 105700 MOVE "( ) " TO PR2-DR
- 105800 MOVE SUB4 TO SB2-DR
- 105900 DISPLAY P-SPACE
- 106000 DISPLAY DIS-REC
- 106100 MOVE 323 TO PAR-DR
- 106200 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 106300 MOVE "ACRE-SF-TOT" TO FAN-DR
- 106400 MOVE ACRE-SF-TOT TO FA1-DR
- 106500 MOVE "/" TO SGN-DR
- 106600 MOVE PLANTS-ACUM TO FB-DR
- 106700 MOVE "PLANTS-ACUM" TO FBN-DR
- 106800 MOVE PIA-FC (SUB4) TO FC-DR
- 106900 MOVE "PIA-FC (SUB4)" TO FCN-DR
- 107000 MOVE "( ) " TO PR3-DR
- 107100 MOVE SUB4 TO SB3-DR
- 107200 DISPLAY P-SPACE
- 107300 DISPLAY DIS-REC.
- 107400 GO TO 320-LP-TB.
- 107500 310-EXIT.
- 107600 EXIT.
- 107700 400-REC-7-PROC.
- 107800 MOVE PLANT-TYP-RK7 TO TYPE-SPEC-HLD.
- 107900 IF PLOT-SIZE-RK7 = 1
- 108000 MOVE 100 TO ACRE-FRAC-FAH ELSE
- 108100 MOVE 200 TO ACRE-FRAC-FAH.
- 108200 MOVE 8 TO AGE.
- 108300 IF AGE-CLS-PLANT-RK0 = "S" MOVE 1 TO AGE.
- 108400 IF AGE-CLS-PLANT-RK0 = "P" MOVE 2 TO AGE.
- 108500 IF AGE-CLS-PLANT-RK0 = "Y" MOVE 3 TO AGE.
- 108600 IF AGE-CLS-PLANT-RK0 = "M" MOVE 4 TO AGE.
- 108700 IF AGE-CLS-PLANT-RK0 = "O" MOVE 5 TO AGE.
- 108800 IF AGE-CLS-PLANT-RK0 = "D" MOVE 6 TO AGE.
- 108900 IF AGE-CLS-PLANT-RK0 = "R" MOVE 7 TO AGE.
- 109000 MOVE TOT-PLANTS (TAB-KEY-0) TO PLANT-TOT-HLD.
- 109100 IF PW-PLOT-TOT = ZERO MOVE 10 TO PW-PLOT-TOT.
- 109200 MOVE PLOTS-CHRZ-HLD TO PLOT-TOT-AC-TB (AGE).
- 109300* IF FAC-IN NOT = FAC-HLD
- 109400* ADD 1 TO PLOT-TOT-AC-TB (AGE).
- 109500 ADD PLANT-TOT-HLD TO PLANT-TOT-AC-TB (AGE).
- 109600 ADD PLANT-TOT-HLD TO PLANT-TOT-HGT.
- 109700* IF TYPE-SPEC-HLD = "G" OR "F"
- 109800* ADD PLANT-TOT-HLD TO PLANT-TOT-AVAIL.
- 109900 IF TYPE-SPEC-HLD = "T" OR "S"
- 110000 ADD PLANT-TOT-HLD TO PLANT-TOT-CROWN.
- 110100 IF (AVG-HGT-PLANT-RK0 > ZERO) AND PLANT-TOT-HLD > ZERO
- 110200 MULTIPLY PLANT-TOT-HLD BY AVG-HGT-PLANT-RK0
- 110300 GIVING AVG-HGT-SUM
- 110400 ADD AVG-HGT-SUM TO AVG-HGT-TOT.
- 110500 IF (AVG-HGT-PLANT-RK0 > ZERO) AND (PLANT-TOT-HLD > ZERO)
- 110600 AND (AUDIT = 1)
- 110700 MOVE 400 TO PAR-DR
- 110800 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 110900 MOVE "PLANT-TOT-HLD" TO FAN-DR
- 111000 MOVE PLANT-TOT-HLD TO FA-DR
- 111100 MOVE "X" TO SGN-DR
- 111200 MOVE AVG-HGT-PLANT-RK0 TO FB1-DR
- 111300 MOVE "AVG-HGT-PLANT-RK0" TO FBN-DR
- 111400 MOVE AVG-HGT-SUM TO FC1-DR
- 111500 MOVE "AVG-HGT-SUM" TO FCN-DR
- 111600 DISPLAY P-SPACE
- 111700 DISPLAY DIS-REC
- 111800 MOVE 401 TO PAR-DR
- 111900 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 112000 MOVE "AVG-HGT-SUM" TO FAN-DR
- 112100 MOVE AVG-HGT-SUM TO FA1-DR
- 112200 MOVE "+" TO SGN-DR
- 112300 MOVE " = " TO FILLER-DR
- 112400 MOVE SPACE TO FBS-DR
- 112500 MOVE SPACE TO FBN-DR
- 112600 MOVE AVG-HGT-TOT TO FC1-DR
- 112700 MOVE "AVG-HGT-TOT" TO FCN-DR
- 112800 DISPLAY P-SPACE
- 112900 DISPLAY DIS-REC.
- 113000 IF (TYPE-SPEC-HLD = "T" OR "S") AND
- 113100 (AVG-CROWN-DIA-RK0 > ZERO) AND
- 113200 (PLANT-TOT-HLD > ZERO)
- 113300 MULTIPLY PLANT-TOT-HLD BY AVG-CROWN-DIA-RK0
- 113400 GIVING AVG-CROWN-SUM
- 113500 ADD AVG-CROWN-SUM TO AVG-CROWN-TOT.
- 113600 IF (TYPE-SPEC-HLD = "T" OR "S") AND
- 113700 (AVG-CROWN-DIA-RK0 > ZERO) AND
- 113800 (PLANT-TOT-HLD > ZERO)
- 113900 AND (AUDIT = 1)
- 114000 MOVE 402 TO PAR-DR
- 114100 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 114200 MOVE "PLANT-TOT-HLD" TO FAN-DR
- 114300 MOVE PLANT-TOT-HLD TO FA-DR
- 114400 MOVE "X" TO SGN-DR
- 114500 MOVE AVG-CROWN-DIA-RK0 TO FB1-DR
- 114600 MOVE "AVG-CROWN-DIA-RK0" TO FBN-DR
- 114700 MOVE AVG-CROWN-SUM TO FC1-DR
- 114800 MOVE "AVG-CROWN-SUM" TO FCN-DR
- 114900 DISPLAY P-SPACE
- 115000 DISPLAY DIS-REC
- 115100 MOVE 402 TO PAR-DR
- 115200 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 115300 MOVE "AVG-CROWN-SUM" TO FAN-DR
- 115400 MOVE AVG-CROWN-SUM TO FA1-DR
- 115500 MOVE "+" TO SGN-DR
- 115600 MOVE " = " TO FILLER-DR
- 115700 MOVE SPACE TO FBS-DR
- 115800 MOVE SPACE TO FBN-DR
- 115900 MOVE AVG-CROWN-TOT TO FC1-DR
- 116000 MOVE "AVG-CROWN-TOT" TO FCN-DR
- 116100 DISPLAY P-SPACE
- 116200 DISPLAY DIS-REC.
- 116300* IF TYPE-SPEC-HLD = "G" OR "F" NEXT SENTENCE
- 116400* ELSE
- 116500* PERFORM 020-RD-IN
- 116600* GO TO 040-LOAD-REC.
- 116700* IF CLS-PLANT-AVAIL-RK0 = " " OR "A"
- 116800* MOVE 1.00 TO AVG-AVAIL-PCT.
- 116900* IF CLS-PLANT-AVAIL-RK0 = "P" MOVE 0.50 TO AVG-AVAIL-PCT.
- 117000* IF CLS-PLANT-AVAIL-RK0 = "U" MOVE 0.00 TO AVG-AVAIL-PCT.
- 117100* IF CLS-PLANT-AVAIL-RK0 = "P" MOVE 0.75 TO AVG-AVAIL-PCT.
- 117200* IF CLS-PLANT-AVAIL-RK0 = "H" MOVE 0.50 TO AVG-AVAIL-PCT.
- 117300* IF CLS-PLANT-AVAIL-RK0 = "L" MOVE 0.25 TO AVG-AVAIL-PCT.
- 117400* IF (AVG-AVAIL-PCT > ZERO) AND
- 117500* (PLANT-TOT-HLD > ZERO)
- 117600* MULTIPLY AVG-AVAIL-PCT BY PLANT-TOT-HLD
- 117700* GIVING AVG-AVAIL-SUM
- 117800* ADD AVG-AVAIL-SUM TO AVG-AVAIL-TOT.
- 117900* IF (AVG-AVAIL-PCT > ZERO) AND
- 118000* (PLANT-TOT-HLD > ZERO)
- 118100* AND (AUDIT = 1)
- 118200* MOVE 403 TO PAR-DR
- 118300* MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 118400* MOVE "AVG-AVAIL-PCT" TO FAN-DR
- 118500* MOVE AVG-AVAIL-PCT TO FA2-DR
- 118600* MOVE "X" TO SGN-DR
- 118700* MOVE PLANT-TOT-HLD TO FB-DR
- 118800* MOVE "PLANT-TOT-HLD" TO FBN-DR
- 118900* MOVE AVG-AVAIL-SUM TO FC-DR
- 119000* MOVE "AVG-AVAIL-SUM" TO FCN-DR
- 119100* DISPLAY P-SPACE
- 119200* DISPLAY DIS-REC
- 119300* MOVE 404 TO PAR-DR
- 119400* MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 119500* MOVE "AVG-AVAIL-SUM" TO FAN-DR
- 119600* MOVE AVG-AVAIL-SUM TO FA-DR
- 119700* MOVE "+" TO SGN-DR
- 119800* MOVE " = " TO FILLER-DR
- 119900* MOVE SPACE TO FBS-DR
- 120000* MOVE SPACE TO FBN-DR
- 120100* MOVE AVG-AVAIL-TOT TO FC-DR
- 120200* MOVE "AVG-AVAIL-TOT" TO FCN-DR
- 120300* DISPLAY P-SPACE
- 120400* DISPLAY DIS-REC.
- 120500 PERFORM 020-RD-IN.
- 120600 GO TO 040-LOAD-REC.
- 120700 410-CAL-7-PROC.
- 120800 MOVE ZERO TO SUB4.
- 120900 412-LP-TB.
- 121000 ADD 1 TO SUB4.
- 121100 IF SUB4 = 8
- 121200 MOVE ZERO TO SUB4
- 121300 GO TO 430-HGT-CROWN-CAL.
- 121400 IF (PLANT-TOT-AC-TB (SUB4) = ZERO)
- 121500 GO TO 412-LP-TB.
- 121600 IF TYPE-SPEC-HLD = "T" OR "S"
- 121700 MULTIPLY ACRE-FRAC-FAH BY PLANT-TOT-AC-TB (SUB4)
- 121800 GIVING PLANTS-ACUM
- 121900 DIVIDE PLOT-TOT-AC-TB (SUB4) INTO PLANTS-ACUM
- 122000 GIVING PIA-AC (SUB4).
- 122100 IF (TYPE-SPEC-HLD = "T" OR "S")
- 122200 AND (AUDIT = 1)
- 122300 MOVE 412 TO PAR-DR
- 122400 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 122500 MOVE "ACRE-FRAC-FAH" TO FAN-DR
- 122600 MOVE ACRE-FRAC-FAH TO FA-DR
- 122700 MOVE "X" TO SGN-DR
- 122800 MOVE PLANT-TOT-AC-TB (SUB4) TO FB-DR
- 122900 MOVE "PLANT-TOT-AC-TB (SUB4)" TO FBN-DR
- 123000 MOVE PLANTS-ACUM TO FC-DR
- 123100 MOVE "PLANTS-ACUM" TO FCN-DR
- 123200 MOVE "( ) " TO PR2-DR
- 123300 MOVE SUB4 TO SB2-DR
- 123400 DISPLAY P-SPACE
- 123500 DISPLAY DIS-REC
- 123600 MOVE 413 TO PAR-DR
- 123700 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 123800 MOVE "PLOT-TOT-AC-TB (SUB4)" TO FAN-DR
- 123900 MOVE PLOT-TOT-AC-TB (SUB4) TO FA-DR
- 124000 MOVE "/" TO SGN-DR
- 124100 MOVE PLANTS-ACUM TO FB-DR
- 124200 MOVE "PLANTS-ACUM" TO FBN-DR
- 124300 MOVE PIA-AC (SUB4) TO FC-DR
- 124400 MOVE "PIA-AC (SUB4)" TO FCN-DR
- 124500 MOVE "( ) " TO PR1-DR
- 124600 MOVE SUB4 TO SB1-DR
- 124700 MOVE "( ) " TO PR3-DR
- 124800 MOVE SUB4 TO SB3-DR
- 124900 DISPLAY P-SPACE
- 125000 DISPLAY DIS-REC.
- 125100 IF (TYPE-SPEC-HLD = "G" OR "F")
- 125200 AND (PLOT-SAMP-SZ-FAH = ZERO)
- 125300 IF PLOT-SIZE-0 = 1 MOVE 435.69 TO PLOT-SAMP-SZ-FAH
- 125400 ELSE
- 125500 IF PLOT-SIZE-0 = 2 MOVE 217.80 TO PLOT-SAMP-SZ-FAH.
- 125600 IF TYPE-SPEC-HLD = "G" OR "F"
- 125700 MULTIPLY PLOT-TOT-AC-TB (SUB4) BY PLOT-SAMP-SZ-FAH
- 125800 GIVING ACRE-SF-TOT
- 125900 MULTIPLY 43560 BY PLANT-TOT-AC-TB (SUB4)
- 126000 GIVING PLANTS-ACUM
- 126100 DIVIDE ACRE-SF-TOT INTO PLANTS-ACUM
- 126200 GIVING PIA-AC (SUB4) ROUNDED.
- 126300 IF (TYPE-SPEC-HLD = "G" OR "F")
- 126400 AND (AUDIT = 1)
- 126500 MOVE 413 TO PAR-DR
- 126600 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 126700 MOVE "PLOT-TOT-AC-TB (SUB4)" TO FAN-DR
- 126800 MOVE PLOT-TOT-AC-TB (SUB4) TO FA-DR
- 126900 MOVE "X" TO SGN-DR
- 127000 MOVE PLOT-SAMP-SZ-FAH TO FB2-DR
- 127100 MOVE "PLOT-SAMP-SZ-FAH" TO FBN-DR
- 127200 MOVE ACRE-SF-TOT TO FC1-DR
- 127300 MOVE "ACRE-SF-TOT" TO FCN-DR
- 127400 MOVE "( ) " TO PR1-DR
- 127500 MOVE SUB4 TO SB1-DR
- 127600 DISPLAY P-SPACE
- 127700 DISPLAY DIS-REC
- 127800 MOVE 414 TO PAR-DR
- 127900 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 128000 MOVE "CONSTANT" TO FAN-DR
- 128100 MOVE 43560 TO FA-DR
- 128200 MOVE "X" TO SGN-DR
- 128300 MOVE PLANT-TOT-AC-TB (SUB4) TO FB-DR
- 128400 MOVE "PLANT-TOT-AC-TB (SUB4)" TO FBN-DR
- 128500 MOVE PLANTS-ACUM TO FC-DR
- 128600 MOVE "PLANTS-ACUM" TO FCN-DR
- 128700 MOVE "( ) " TO PR2-DR
- 128800 MOVE SUB4 TO SB2-DR
- 128900 DISPLAY P-SPACE
- 129000 DISPLAY DIS-REC
- 129100 MOVE 415 TO PAR-DR
- 129200 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 129300 MOVE "ACRE-SF-TOT" TO FAN-DR
- 129400 MOVE ACRE-SF-TOT TO FA1-DR
- 129500 MOVE "/" TO SGN-DR
- 129600 MOVE PLANTS-ACUM TO FB-DR
- 129700 MOVE "PLANTS-ACUM" TO FBN-DR
- 129800 MOVE PIA-AC (SUB4) TO FC-DR
- 129900 MOVE "PIA-AC (SUB4)" TO FCN-DR
- 130000 MOVE "( ) " TO PR3-DR
- 130100 MOVE SUB4 TO SB3-DR
- 130200 DISPLAY P-SPACE
- 130300 DISPLAY DIS-REC.
- 130400 GO TO 412-LP-TB.
- 130500 430-HGT-CROWN-CAL.
- 130600 IF (PLANT-TOT-HGT > ZERO) AND (AVG-HGT-TOT > ZERO)
- 130700 DIVIDE PLANT-TOT-HGT INTO AVG-HGT-TOT
- 130800 GIVING AVG-HGT.
- 130900 IF (PLANT-TOT-HGT > ZERO) AND (AVG-HGT-TOT > ZERO)
- 131000 AND (AUDIT = 1)
- 131100 MOVE 430 TO PAR-DR
- 131200 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 131300 MOVE "PLANT-TOT-HGT" TO FAN-DR
- 131400 MOVE PLANT-TOT-HGT TO FA-DR
- 131500 MOVE "/" TO SGN-DR
- 131600 MOVE AVG-HGT-TOT TO FB1-DR
- 131700 MOVE "AVG-HGT-TOT" TO FBN-DR
- 131800 MOVE AVG-HGT TO FC1-DR
- 131900 MOVE "AVG-HGT" TO FCN-DR
- 132000 DISPLAY P-SPACE
- 132100 DISPLAY DIS-REC.
- 132200 IF (PLANT-TOT-CROWN > ZERO) AND (AVG-CROWN-TOT > ZERO)
- 132300 DIVIDE PLANT-TOT-CROWN INTO AVG-CROWN-TOT
- 132400 GIVING AVG-CROWN.
- 132500 IF (PLANT-TOT-CROWN > ZERO) AND (AVG-CROWN-TOT > ZERO)
- 132600 AND (AUDIT = 1)
- 132700 MOVE 431 TO PAR-DR
- 132800 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 132900 MOVE "PLANT-TOT-CROWN" TO FAN-DR
- 133000 MOVE PLANT-TOT-CROWN TO FA-DR
- 133100 MOVE "/" TO SGN-DR
- 133200 MOVE AVG-CROWN-TOT TO FB1-DR
- 133300 MOVE "AVG-CROWN-TOT" TO FBN-DR
- 133400 MOVE AVG-CROWN TO FC1-DR
- 133500 MOVE "AVG-CROWN" TO FCN-DR
- 133600 DISPLAY P-SPACE
- 133700 DISPLAY DIS-REC.
- 133800* IF (PLANT-TOT-AVAIL > ZERO) AND (AVG-AVAIL-TOT > ZERO)
- 133900* DIVIDE PLANT-TOT-AVAIL INTO AVG-AVAIL-TOT
- 134000* GIVING AVG-AVAIL.
- 134100* IF (PLANT-TOT-AVAIL > ZERO) AND (AVG-AVAIL-TOT > ZERO)
- 134200* AND (AUDIT = 1)
- 134300* MOVE 432 TO PAR-DR
- 134400* MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 134500* MOVE "PLANT-TOT-AVAIL" TO FAN-DR
- 134600* MOVE PLANT-TOT-AVAIL TO FA-DR
- 134700* MOVE "/" TO SGN-DR
- 134800* MOVE AVG-AVAIL-TOT TO FB-DR
- 134900* MOVE "AVG-AVAIL-TOT" TO FBN-DR
- 135000* MOVE AVG-AVAIL TO FC2-DR
- 135100* MOVE "AVG-AVAIL" TO FCN-DR
- 135200* DISPLAY P-SPACE
- 135300* DISPLAY DIS-REC.
- 135400 MOVE ZERO TO SUB2.
- 135500 SUBTRACT UTIL-AVG-2 FROM 100 GIVING PW-WUAF.
- 135600 IF AUDIT = 1
- 135700 MOVE 433 TO PAR-DR
- 135800 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 135900 MOVE "CONSTANT" TO FAN-DR
- 136000 MOVE 100 TO FA-DR
- 136100 MOVE "-" TO SGN-DR
- 136200 MOVE UTIL-AVG-2 TO FB-DR
- 136300 MOVE "UTIL-AVG-2" TO FBN-DR
- 136400 MOVE PW-WUAF TO FC-DR
- 136500 MOVE "PW-WUAF" TO FCN-DR
- 136600 DISPLAY P-SPACE
- 136700 DISPLAY DIS-REC.
- 136800 DIVIDE PW-WUAF INTO 100 GIVING
- 136900 PW-WAUF.
- 137000 IF AUDIT = 1
- 137100 MOVE 434 TO PAR-DR
- 137200 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 137300 MOVE "PW-WUAF" TO FAN-DR
- 137400 MOVE PW-WUAF TO FA-DR
- 137500 MOVE "/" TO SGN-DR
- 137600 MOVE 100 TO FB-DR
- 137700 MOVE "CONSTANT" TO FBN-DR
- 137800 MOVE PW-WAUF TO FC2-DR
- 137900 MOVE "PW-WAUF" TO FCN-DR
- 138000 DISPLAY P-SPACE
- 138100 DISPLAY DIS-REC.
- 138200 450-LP.
- 138300 IF SUB2 = 4
- 138400 MOVE ZERO TO SUB2
- 138500 GO TO 460-BUILD-SUMMARY.
- 138600 ADD 1 TO SUB2.
- 138700 IF GRAM-HC-TB (SUB2) = ZERO GO TO 450-LP.
- 138800 MOVE GRAM-HC-TB (SUB2) TO PW-GRAMS-HLD.
- 138900* MOVE PLOT-TOT-HC-TB (SUB2) TO PW-PLOT-TOT.
- 139000 MULTIPLY 100 BY PW-GRAMS-HLD GIVING PW-GRAMS.
- 139100 IF AUDIT = 1
- 139200 MOVE 450 TO PAR-DR
- 139300 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 139400 MOVE "PW-GRAMS-HLD" TO FAN-DR
- 139500 MOVE PW-GRAMS-HLD TO FA-DR
- 139600 MOVE "X" TO SGN-DR
- 139700 MOVE 100 TO FB-DR
- 139800 MOVE "CONSTANT" TO FBN-DR
- 139900 MOVE PW-GRAMS TO FC-DR
- 140000 MOVE "PW-GRAMS" TO FCN-DR
- 140100 MOVE "( ) " TO PR1-DR
- 140200 MOVE SUB2 TO SB1-DR
- 140300 DISPLAY P-SPACE
- 140400 DISPLAY DIS-REC.
- 140500 DIVIDE PW-PLOT-TOT INTO PW-GRAMS GIVING PW-GRAMS-HLD.
- 140600 IF AUDIT = 1
- 140700 MOVE 451 TO PAR-DR
- 140800 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 140900 MOVE "PW-PLOT-TOT" TO FAN-DR
- 141000 MOVE PW-PLOT-TOT TO FA-DR
- 141100 MOVE "/" TO SGN-DR
- 141200 MOVE PW-GRAMS TO FB-DR
- 141300 MOVE "PW-GRAMS" TO FBN-DR
- 141400 MOVE PW-GRAMS-HLD TO FC-DR
- 141500 MOVE "PW-GRAMS-HLD" TO FCN-DR
- 141600 MOVE "( ) " TO PR1-DR
- 141700 MOVE SUB2 TO SB1-DR
- 141800 DISPLAY P-SPACE
- 141900 DISPLAY DIS-REC.
- 142000 MULTIPLY .96 BY PW-GRAMS-HLD GIVING PW-GRAMS.
- 142100 IF AUDIT = 1
- 142200 MOVE 452 TO PAR-DR
- 142300 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 142400 MOVE "PW-GRAMS-HLD" TO FAN-DR
- 142500 MOVE PW-GRAMS-HLD TO FA-DR
- 142600 MOVE "X" TO SGN-DR
- 142700 MOVE CON96 TO FB2-DR
- 142800 MOVE "CONSTANT" TO FBN-DR
- 142900 MOVE PW-GRAMS TO FC-DR
- 143000 MOVE "PW-GRAMS" TO FCN-DR
- 143100 MOVE "( ) " TO PR1-DR
- 143200 MOVE SUB2 TO SB1-DR
- 143300 DISPLAY P-SPACE
- 143400 DISPLAY DIS-REC.
- 143500 DIVIDE PW-SIZE INTO PW-GRAMS GIVING PW-LBS-ACRE ROUNDED.
- 143600 IF AUDIT = 1
- 143700 MOVE 453 TO PAR-DR
- 143800 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 143900 MOVE "PW-SIZE" TO FAN-DR
- 144000 MOVE PW-SIZE TO FA2-DR
- 144100 MOVE "/" TO SGN-DR
- 144200 MOVE PW-GRAMS TO FB-DR
- 144300 MOVE "PW-GRAMS" TO FBN-DR
- 144400 MOVE PW-LBS-ACRE TO FC-DR
- 144500 MOVE "PW-LBS-ACRE" TO FCN-DR
- 144600 DISPLAY P-SPACE
- 144700 DISPLAY DIS-REC.
- 144800 MULTIPLY PW-WAUF BY PW-LBS-ACRE
- 144900 GIVING PW-PROD (SUB2) ROUNDED.
- 145000 IF AUDIT = 1
- 145100 MOVE 454 TO PAR-DR
- 145200 MOVE SPACE TO PR1-DR PR2-DR PR3-DR
- 145300 MOVE "PW-WAUF" TO FAN-DR
- 145400 MOVE PW-WAUF TO FA2-DR
- 145500 MOVE "X" TO SGN-DR
- 145600 MOVE PW-LBS-ACRE TO FB-DR
- 145700 MOVE "PW-LBS-ACRE" TO FBN-DR
- 145800 MOVE PW-PROD (SUB2) TO FC-DR
- 145900 MOVE "PW-PROD (SUB2)" TO FCN-DR
- 146000 MOVE "( ) " TO PR3-DR
- 146100 MOVE SUB2 TO SB3-DR
- 146200 DISPLAY P-SPACE
- 146300 DISPLAY DIS-REC.
- 146400 GO TO 450-LP.
- 146500 460-BUILD-SUMMARY.
- 146600 MOVE SPACE TO DET-1 DET-2, REC-KEY8.
- 146700 MOVE SWA-SCH TO SWA-P.
- 146800 MOVE TRN-NUM-SCH TO TRN-P.
- 146900 MOVE SPECIES-CD-SCH TO SPECIES-CD-P.
- 147000 MOVE TYPE-SPEC-HLD TO SPECIES-TYPE-P.
- 147100 MOVE PLANT-TOTAL TO TOT-PLANTS-RK8 TOT-PLANTS-P.
- 147200 MOVE SWAT-CNTL-HLD TO SWAT-RK8.
- 147300 MOVE 8 TO REC-KEY-RK8.
- 147400 MOVE SPEC-HLD TO SPECIES-KEY-RK8.
- 147500 IF TYPE-SPEC-HLD = "T" OR "S"
- 147600 MOVE "3" TO PLANT-TYP-RK8 ELSE
- 147700 IF TYPE-SPEC-HLD = "G"
- 147800 MOVE "1" TO PLANT-TYP-RK8 ELSE
- 147900 IF TYPE-SPEC-HLD = "F"
- 148000 MOVE "2" TO PLANT-TYP-RK8.
- 148100 MOVE AVG-HGT TO AVG-HT-RK8 AVG-HGT-P.
- 148200 MOVE AVG-CROWN TO AVG-CROWN-RK8 AVG-CROWN-P.
- 148300 IF (AVAIL-SW = ZERO) AND (AVG-AV-PCT = ZERO)
- 148400 MOVE 100 TO AVG-AV-PCT.
- 148500 MOVE ZERO TO AVAIL-SW.
- 148600 MOVE AVG-AV-PCT TO WTD-AVG-AVAIL-RK8 WTD-AVG-AVAIL-P
- 148700 IF UTIL-AVG-RD = 100 MOVE ZERO TO UTIL-AVG-RD.
- 148800 MOVE UTIL-AVG-RD TO WTD-AVG-UTIL-RK8 WTD-AVG-UTIL-P.
- 148900 IF PHNO-PLOT-AVG = ZERO
- 149000 MOVE 6 TO PHNO-PLOT-AVG.
- 149100 IF PHNO-AVG = ZERO
- 149200 MOVE PHNO-PLOT-AVG TO PHNO-AVG.
- 149300 MOVE PHNO-AVG TO WTD-AVG-PHNO-RK8 WTD-AVG-PHNO-P.
- 149400 MOVE GRAM-HC-TB-RD TO GRP-3-RK8.
- 149500 MOVE PW-GRP-PROD TO GRP-4-RK8.
- 149600 MOVE PIA-FC-RD TO GRP-1-RK8.
- 149700 MOVE PIA-AC2 TO GRP-2-RK8.
- 149800 MOVE ZERO TO SUB3.
- 149900 470-LP-TB.
- 150000 ADD 1 TO SUB3.
- 150100 IF SUB3 < 5
- 150200 MOVE TOT-GRAMS-RK8 (SUB3) TO GRAMS-HGT-CLS-P (SUB3)
- 150300 MOVE PW-PROD (SUB3) TO PROD-HGT-CLS-P (SUB3).
- 150400 IF SUB3 < 7
- 150500 MOVE FORM-CLS-RK8 (SUB3) TO PLANTS-FORM-CLS-P (SUB3)
- 150600 MOVE AGE-CLS-RK8 (SUB3) TO PLANTS-AGE-CLS-P (SUB3)
- 150700 GO TO 470-LP-TB.
- 150800 MOVE AGE-CLS-RK8 (SUB3) TO PLANTS-AGE-CLS-P (SUB3).
- 150900 MOVE REC-KEY8 TO FDR-D8.
- 151000 MOVE PLOTS-CHRZ-HLD TO PLOTS-CHRZ-D8.
- 151100 IF CHRZ-SW = 1
- 151200 MOVE PLOTS-CHRZ-HLD-2 TO PLOTS-CHRZ-HLD
- 151300 MOVE ZERO TO CHRZ-SW.
- 151400 WRITE FDR-D8.
- 151500 ADD 1 TO REC-CNT.
- 151600 MOVE SPACE TO DIS-DT1 DIS-DT2.
- 151700 INITIALIZE PLANT-TOT-TABLE, PLANT-CAL-TABLE,
- 151800 PLANT-CAL-HLD, UTIL-PHENO-TABLE, PLANT-TOTAL,
- 151900 UTIL-PHENO-HLD, HT-CLS-TABLE, FORM-CLS-TABLE,
- 152000 AGE-CLS-TABLE, FORM-AGE-HOLD, AVG-HGT-CROWN-AVL
- 152100 PROD-WGT-HLD DIS-DT1 DIS-DT2.
- 152200 IF PRT-SW = 1 GO TO 475-PASS.
- 152300 IF LINE-CNT > 50
- 152400 PERFORM 500-OFLO THRU 500-EXIT.
- 152500 WRITE FDR-P1 FROM DET-1 BEFORE 1.
- 152600 WRITE FDR-P1 FROM DET-2 BEFORE 1.
- 152700 WRITE FDR-P1 FROM P-SPACE BEFORE 1.
- 152800 ADD 3 TO LINE-CNT.
- 152900 475-PASS.
- 153000 IF END-SW = 1
- 153100 GO TO 700-END.
- 153200 IF SDRP-SCH NOT = SDRP-D7
- 153300 MOVE 99 TO LINE-CNT
- 153400 MOVE 0 TO SWAT-SW SPEC-SW
- 153500 GO TO 030-MV-IN.
- 153600 IF SWAT-SW = 1
- 153700 MOVE 0 TO SWAT-SW SPEC-SW
- 153800 MOVE 55 TO LINE-CNT
- 153900 GO TO 030-MV-IN.
- 154000 IF SPEC-SW = 1
- 154100 MOVE 0 TO SPEC-SW
- 154200 GO TO 030-MV-IN.
- 154300 500-OFLO.
- 154400 IF SDRP-SCH NOT = SDRP-HLD
- 154500 MOVE SDRP-SCH TO SDRP-HLD
- 154600 ELSE GO TO 510-WRITE.
- 154700 MOVE ADST-CD-SCH TO DE-CD-8822-DEC.
- 154800 MOVE 0003 TO DE-NO-8801-DEC.
- 154900 FIND ANY CODE-DEC.
- 155000 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 155100 IF OK
- 155200 GET CODE-DEC
- 155300 MOVE DE-CD-NAM-8823-DEC TO FUNC-HLD
- 155400 MOVE ST-NM-HLD TO SN-HD-3
- 155500 ELSE MOVE "UNKNOWN" TO SN-HD-3
- 155600 DN-HD-3 RAN-HD-3 PN-HD-3
- 155700 GO TO 510-WRITE.
- 155800 MOVE SD-SCH TO DE-CD-8822-DEC.
- 155900 MOVE 0003 TO DE-NO-8801-DEC.
- 156000 FIND ANY CODE-DEC.
- 156100 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 156200 IF OK
- 156300 GET CODE-DEC
- 156400 ELSE MOVE "UNKNOWN" TO
- 156500 DN-HD-3 RAN-HD-3 PN-HD-3
- 156600 GO TO 510-WRITE.
- 156700 FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
- 156800 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 156900 IF OK
- 157000 GET CODE-EXPL-DECE
- 157100 MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HLD
- 157200 MOVE DIST-NM-HLD TO DN-HD-3
- 157300 ELSE
- 157400 MOVE "UNKNOWN" TO DN-HD-3 RAN-HD-3 PN-HD-3
- 157500 GO TO 510-WRITE.
- 157600 MOVE SDR-SCH TO DE-CD-8822-DEC.
- 157700 MOVE 0003 TO DE-NO-8801-DEC.
- 157800 FIND ANY CODE-DEC.
- 157900 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 158000 IF OK
- 158100 GET CODE-DEC
- 158200 ELSE
- 158300 MOVE "UNKNOWN" TO RAN-HD-3 PN-HD-3
- 158400 GO TO 510-WRITE.
- 158500 FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
- 158600 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 158700 IF OK
- 158800 GET CODE-EXPL-DECE
- 158900 MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HLD
- 159000 MOVE RA-NM-HLD TO RAN-HD-3
- 159100 ELSE
- 159200 MOVE "UNKNOWN" TO RAN-HD-3 PN-HD-3
- 159300 GO TO 510-WRITE.
- 159400 MOVE SDRP-SCH TO DE-CD-8822-DEC.
- 159500 MOVE 0003 TO DE-NO-8801-DEC.
- 159600 FIND ANY CODE-DEC.
- 159700 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 159800 IF OK
- 159900 GET CODE-DEC
- 160000 ELSE MOVE "UNKNOWN" TO PN-HD-3
- 160100 GO TO 510-WRITE.
- 160200 FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
- 160300 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 160400 IF OK
- 160500 GET CODE-EXPL-DECE
- 160600 MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HLD
- 160700 MOVE PU-NM-HLD TO PN-HD-3
- 160800 ELSE
- 160900 MOVE "UNKNOWN" TO PN-HD-3.
- 161000 510-WRITE.
- 161100 IF PRT-SW = 1 GO TO 500-EXIT.
- 161200 IF LINE-CNT = 99
- 161300 MOVE ZERO TO PG-CNT.
- 161400 ADD 1 TO PG-CNT.
- 161500* IF PG-CNT > 100
- 161600* MOVE ZERO TO LINE-CNT
- 161700* GO TO 500-EXIT.
- 161800 MOVE ZERO TO LINE-CNT.
- 161900 MOVE PG-CNT TO PG-HD-1.
- 162000 MOVE ADST-CD-SCH TO ST-HD-3.
- 162100 MOVE DIST-CD-SCH TO DS-HD-3.
- 162200 MOVE PLU-CD-SCH TO PS-HD-3.
- 162300 MOVE RA-CD-SCH TO RA-HD-3.
- 162400 WRITE FDR-P1 FROM P-SPACE BEFORE ADVANCING PAGE.
- 162500 WRITE FDR-P1 FROM HEAD-1 BEFORE 1.
- 162600 WRITE FDR-P1 FROM HEAD-2 BEFORE 1.
- 162700 WRITE FDR-P1 FROM HEAD-3 BEFORE 1.
- 162800 WRITE FDR-P1 FROM HEAD-4 BEFORE 2.
- 162900 WRITE FDR-P1 FROM HEAD-5 BEFORE 1.
- 163000 WRITE FDR-P1 FROM HEAD-6 BEFORE 1.
- 163100 WRITE FDR-P1 FROM HEAD-7 BEFORE 2.
- 163200 MOVE 10 TO LINE-CNT.
- 163300 500-EXIT.
- 163400 EXIT.
- 163500 700-END.
- 163600 DISPLAY REC-CNT "REC-CNT".
- 163700 CLOSE FILE-D7, FILE-D8, FILE-P1. FINISH DIC-DE.
- 163800 STOP RUN.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES110U.
- 000300* INITIAL EDIT/UPDATE OF PLANTS (PHENO/WEIGHTS),
- 000400* ANIMALS (FORAGE/USE) FACTORS - V6, VF, VU, VP FORMATS
- 000500*
- 000600 AUTHOR. CARLANDER, RON BAKER.
- 000700 INSTALLATION. BLM.
- 000800 DATE-WRITTEN. AUGUST 1979.
- 000900 ENVIRONMENT DIVISION.
- 001000 CONFIGURATION SECTION.
- 001100 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001200 OBJECT-COMPUTER. LEVEL-66-ASCII SEQUENCE IS EBCDIC.
- 001300 INPUT-OUTPUT SECTION.
- 001400 FILE-CONTROL.
- 001500 SELECT NEW-FILE ASSIGN D1
- 001600 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001700 SELECT TRAN-FILE ASSIGN I1
- 001800 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001900 SELECT OPTIONAL PREV-FILE ASSIGN I2
- 002000 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002100 SELECT SORT-WORK ASSIGN I1 I2 I3.
- 002200 DATA DIVISION.
- 002300 FILE SECTION.
- 002400 FD PREV-FILE
- 002500 CODE-SET IS GBCD
- 002600 LABEL RECORDS ARE STANDARD
- 002700 DATA RECORDS ARE VF1X-RCD VP1X-RCD VU1X-RCD V61X-RCD.
- 002800 01 VF1X-RCD.
- 002900 05 KEY-VF1X.
- 003000 10 DIC-VF1X.
- 003100 15 REC-TYP-3529-VF1X PIC X(2).
- 003200 15 FMT-NUM-3576-VF1X PIC X(1).
- 003300 15 FMT-CD-3579-VF1X PIC X(1).
- 003400 10 BLM-ADM-U-0003-VF1X.
- 003500 15 BLM-ADM-U-0003-ST-VF1X PIC X(2).
- 003600 15 BLM-ADM-U-0003-DIST-VF1X PIC X(2).
- 003700 15 FILLER PIC XXXX.
- 003800 10 DATA-DATE-6618-VF1X.
- 003900 15 DATA-DATE-6618-YY-VF1X PIC X(2).
- 004000 15 DATA-DATE-6618-MM-VF1X PIC X(2).
- 004100 15 DATA-DATE-6618-DD-VF1X PIC X(2).
- 004200 10 ACTN-CD-7350-VF1X PIC X(1).
- 004300 10 LIN-NUM-3578-VF1X PIC X(4).
- 004400 05 ANML-GRZG-CD-3929-VF1X PIC X(2).
- 004500 05 MON-FORG-RQMT-LBS-3551-VF1X PIC X(4).
- 004600 05 ANML-HGT-CLS-CD-3548-VF1X PIC X(1).
- 004700 05 FILLER PIC X(36).
- 004800 01 VP1X-RCD.
- 004900 05 KEY-VP1X.
- 005000 10 DIC-VP1X.
- 005100 15 REC-TYP-3529-VP1X PIC X(2).
- 005200 15 FMT-NUM-3576-VP1X PIC X(1).
- 005300 15 FMT-CD-3579-VP1X PIC X(1).
- 005400 10 BLM-ADM-U-0003-VP1X.
- 005500 15 BLM-ADM-U-0003-ST-VP1X PIC X(2).
- 005600 15 BLM-ADM-U-0003-DIST-VP1X PIC X(2).
- 005700 15 BLM-ADM-U-0003-RA-VP1X PIC X(2).
- 005800 15 BLM-ADM-U-0003-PLU-VP1X PIC X(2).
- 005900 10 DATA-DATE-6618-VP1X.
- 006000 15 DATA-DATE-6618-YY-VP1X PIC X(2).
- 006100 15 DATA-DATE-6618-MM-VP1X PIC X(2).
- 006200 15 DATA-DATE-6618-DD-VP1X PIC X(2).
- 006300 10 ACTN-CD-7350-VP1X PIC X(1).
- 006400 10 LIN-NUM-3578-VP1X PIC X(4).
- 006500 05 PLANT-CD-2646-VP1X PIC X(7).
- 006600 05 PHNO-GP-VP1X PIC X(32).
- 006700 05 PHNO-ADJ-GP-VP1X REDEFINES PHNO-GP-VP1X.
- 006800 07 PHNO-ADJ-VP1X OCCURS 8 TIMES.
- 006900 09 PHNO-ADJ-1-VP1X PIC XX.
- 007000 09 PHNO-ADJ-2-VP1X PIC XX.
- 007100 05 PHNO-ADJ-FCTR-3545-VP1X REDEFINES PHNO-GP-VP1X
- 007200 OCCURS 8 TIMES PIC 99V99.
- 007300 05 PLANT-TYP-3590-VP1X PIC X.
- 007400 05 FILLER PIC XXXX.
- 007500 01 VU1X-RCD.
- 007600 05 KEY-VU1X.
- 007700 10 DIC-VU1X.
- 007800 15 REC-TYP-3529-VU1X PIC X(2).
- 007900 15 FMT-NUM-3576-VU1X PIC X(1).
- 008000 15 FMT-CD-3579-VU1X PIC X(1).
- 008100 10 BLM-ADM-U-0003-VU1X.
- 008200 15 BLM-ADM-U-0003-ST-VU1X PIC X(2).
- 008300 15 BLM-ADM-U-0003-DIST-VU1X PIC X(2).
- 008400 15 BLM-ADM-U-0003-RA-VU1X PIC X(2).
- 008500 15 BLM-ADM-U-0003-PLU-VU1X PIC X(2).
- 008600 10 DATA-DATE-6618-VU1X.
- 008700 15 DATA-DATE-6618-YY-VU1X PIC X(2).
- 008800 15 DATA-DATE-6618-MM-VU1X PIC X(2).
- 008900 15 DATA-DATE-6618-DD-VU1X PIC X(2).
- 009000 10 ACTN-CD-7350-VU1X PIC X(1).
- 009100 10 DIET-USE-TYP-3917-VU1X PIC X(1).
- 009200 10 LIN-NUM-3578-VU1X PIC X(4).
- 009300 05 PLANT-CD-2646-VU1X PIC X(7).
- 009400 05 AUF-3928-VU1X-RD PIC X(15).
- 009500 05 AUF-3928-VU1X REDEFINES AUF-3928-VU1X-RD
- 009600 OCCURS 5 TIMES PIC XXX.
- 009700 05 ANML-GRZG-CD-3929-VU1X PIC X(2).
- 009800 05 PUF-3511-VU1X PIC X(02) OCCURS 5 TIMES.
- 009900 05 PLANT-TYP-3590-VU1X PIC X.
- 010000 05 FILLER PIC X(7).
- 010100 01 REC-V61X.
- 010200 05 KEY-V61X.
- 010300 10 DIC-V61X.
- 010400 15 REC-TYP-3529-V61X PIC X(2).
- 010500 15 FMT-NUM-3576-V61X PIC X(1).
- 010600 15 FMT-CD-3579-V61X PIC X(1).
- 010700 10 BLM-ADM-U-0003-V61X.
- 010800 15 BLM-ADM-U-0003-ST-V61X PIC X(2).
- 010900 15 BLM-ADM-U-0003-DIST-V61X PIC X(2).
- 011000 15 BLM-ADM-U-0003-RA-V61X PIC X(2).
- 011100 15 BLM-ADM-U-0003-PLU-V61X PIC X(2).
- 011200 10 DATA-DATE-6618-V61X.
- 011300 15 DATA-DATE-6618-YY-V61X PIC X(2).
- 011400 15 DATA-DATE-6618-MM-V61X PIC X(2).
- 011500 15 DATA-DATE-6618-DD-V61X PIC X(2).
- 011600 10 ACTN-CD-7350-V61X PIC X(1).
- 011700 10 LIN-NUM-3578-V61X PIC X(4).
- 011800 05 PLANT-CD-2646-V61X PIC X(7).
- 011900 05 PHNO-STG-CD-3712-V61X PIC X(1).
- 012000 05 GRAMS-GRN-WGT-3941-V61X PIC X(4).
- 012100 05 ADW-PCT-3546-V61X PIC X(3).
- 012200 05 GRAMS-DRY-WGT-3942-V61X PIC X(4).
- 012300 05 GRP-1-V61X.
- 012400 07 BASAL-DIMS-3533-MIN-V61X PIC XXXX.
- 012500 07 BASAL-DIMS-3533-MAX-V61X PIC XXXX.
- 012600 07 CROWN-DIMS-3534-MIN-V61X PIC X(03).
- 012700 07 CROWN-DIMS-3534-MAX-V61X PIC X(03).
- 012800 07 HGT-AVG-3504-V61X PIC X(04).
- 012900 07 AVG-LDR-LGT-7313-V61X PIC X(03).
- 013000 05 PLANT-TYP-3590-V61X PIC X.
- 013100 05 FILLER PIC X(02).
- 013200 FD TRAN-FILE
- 013300 CODE-SET IS GBCD
- 013400 LABEL RECORDS ARE STANDARD
- 013500 DATA RECORD IS TF-RCD.
- 013600 01 TF-RCD.
- 013700 03 REC-TYP-TF PIC XX.
- 013800 03 REC-NUM-CD-TF PIC XX.
- 013900 03 SDRP-TF.
- 014000 05 ST-TF PIC XX.
- 014100 05 DS-TF PIC XX.
- 014200 05 RA-TF PIC XX.
- 014300 05 PU-TF PIC XX.
- 014400 03 DATE-TF PIC X(6).
- 014500 03 ACTN-TF PIC X.
- 014600 03 GRP-1-TF.
- 014700 05 DIET-TYP-VU-TF PIC X.
- 014800 05 LINE-VU-TF PIC XXXX.
- 014900 05 PLANT-CD-VU-TF PIC X(7).
- 015000 05 DATA-VU-TF.
- 015100 07 AUF-GRP-VU-TF PIC X(15).
- 015200 07 ANML-GZ-CD-VU-TF PIC XX.
- 015300 07 PUF-GRP-VU-TF PIC X(10).
- 015400 07 FILLER PIC X(8).
- 015500 03 GRP-2-TF REDEFINES GRP-1-TF.
- 015600 05 LINE-TF PIC XXXX.
- 015700 05 DATA-V6FP-TF.
- 015800 07 PLANT-CD-TF.
- 015900 09 ANML-GZ-CD-VF-TF PIC XX.
- 016000 09 FILLER PIC X(5).
- 016100 07 PHNO-STG-TF PIC X.
- 016200 07 FILLER PIC X(35).
- 016300 FD NEW-FILE
- 016400 CODE-SET IS GBCD
- 016500 LABEL RECORDS ARE STANDARD
- 016600 DATA RECORDS ARE VF1Z-RCD VP1Z-RCD VU1Z-RCD V61Z-RCD.
- 016700 01 VF1Z-RCD.
- 016800 05 KEY-VF1Z.
- 016900 10 DIC-VF1Z.
- 017000 15 REC-TYP-3529-VF1Z PIC X(2).
- 017100 15 FMT-NUM-3576-VF1Z PIC X(1).
- 017200 15 FMT-CD-3579-VF1Z PIC X(1).
- 017300 10 BLM-ADM-U-0003-VF1Z.
- 017400 15 BLM-ADM-U-0003-ST-VF1Z PIC X(2).
- 017500 15 BLM-ADM-U-0003-DIST-VF1Z PIC X(2).
- 017600 15 FILLER PIC XXXX.
- 017700 10 DATA-DATE-6618-VF1Z.
- 017800 15 DATA-DATE-6618-YY-VF1Z PIC X(2).
- 017900 15 DATA-DATE-6618-MM-VF1Z PIC X(2).
- 018000 15 DATA-DATE-6618-DD-VF1Z PIC X(2).
- 018100 10 ACTN-CD-7350-VF1Z PIC X(1).
- 018200 10 LIN-NUM-3578-VF1Z PIC X(4).
- 018300 05 ANML-GRZG-CD-3929-VF1Z PIC X(2).
- 018400 05 MON-FORG-RQMT-LBS-3551-VF1Z PIC X(4).
- 018500 05 ANML-HGT-CLS-CD-3548-VF1Z PIC X(1).
- 018600 05 OPEN-VF1Z PIC X(36).
- 018700 01 VP1Z-RCD.
- 018800 05 KEY-VP1Z.
- 018900 10 DIC-VP1Z.
- 019000 15 REC-TYP-3529-VP1Z PIC X(2).
- 019100 15 FMT-NUM-3576-VP1Z PIC X(1).
- 019200 15 FMT-CD-3579-VP1Z PIC X(1).
- 019300 10 BLM-ADM-U-0003-VP1Z.
- 019400 15 BLM-ADM-U-0003-ST-VP1Z PIC X(2).
- 019500 15 BLM-ADM-U-0003-DIST-VP1Z PIC X(2).
- 019600 15 BLM-ADM-U-0003-RA-VP1Z PIC X(2).
- 019700 15 BLM-ADM-U-0003-PLU-VP1Z PIC X(2).
- 019800 10 DATA-DATE-6618-VP1Z.
- 019900 15 DATA-DATE-6618-YY-VP1Z PIC X(2).
- 020000 15 DATA-DATE-6618-MM-VP1Z PIC X(2).
- 020100 15 DATA-DATE-6618-DD-VP1Z PIC X(2).
- 020200 10 ACTN-CD-7350-VP1Z PIC X(1).
- 020300 10 LIN-NUM-3578-VP1Z PIC X(4).
- 020400 05 PLANT-CD-2646-VP1Z PIC X(7).
- 020500 05 PHNO-GP-VP1Z PIC X(32).
- 020600 05 PHNO-ADJ-GP-VP1Z REDEFINES PHNO-GP-VP1Z.
- 020700 07 PHNO-ADJ-VP1Z OCCURS 8 TIMES.
- 020800 09 PHNO-ADJ-1-VP1Z PIC XX.
- 020900 09 PHNO-ADJ-2-VP1Z PIC XX.
- 021000 05 PHNO-ADJ-FCTR-3545-VP1Z REDEFINES PHNO-GP-VP1Z
- 021100 OCCURS 8 TIMES PIC 99V99.
- 021200 05 PLANT-TYP-3590-VP1Z PIC X.
- 021300 05 OPEN-VP1Z PIC XXXX.
- 021400 01 VU1Z-RCD.
- 021500 05 KEY-VU1Z.
- 021600 10 DIC-VU1Z.
- 021700 15 REC-TYP-3529-VU1Z PIC X(2).
- 021800 15 FMT-NUM-3576-VU1Z PIC X(1).
- 021900 15 FMT-CD-3579-VU1Z PIC X(1).
- 022000 10 BLM-ADM-U-0003-VU1Z.
- 022100 15 BLM-ADM-U-0003-ST-VU1Z PIC X(2).
- 022200 15 BLM-ADM-U-0003-DIST-VU1Z PIC X(2).
- 022300 15 BLM-ADM-U-0003-RA-VU1Z PIC X(2).
- 022400 15 BLM-ADM-U-0003-PLU-VU1Z PIC X(2).
- 022500 10 DATA-DATE-6618-VU1Z.
- 022600 15 DATA-DATE-6618-YY-VU1Z PIC X(2).
- 022700 15 DATA-DATE-6618-MM-VU1Z PIC X(2).
- 022800 15 DATA-DATE-6618-DD-VU1Z PIC X(2).
- 022900 10 ACTN-CD-7350-VU1Z PIC X(1).
- 023000 10 DIET-USE-TYP-3917-VU1Z PIC X(1).
- 023100 10 LIN-NUM-3578-VU1Z PIC X(4).
- 023200 05 PLANT-CD-2646-VU1Z PIC X(7).
- 023300 05 AUF-3928-VU1Z-RD PIC X(15).
- 023400 05 AUF-3928-VU1Z REDEFINES AUF-3928-VU1Z-RD
- 023500 OCCURS 5 TIMES PIC XXX.
- 023600 05 ANML-GRZG-CD-3929-VU1Z PIC X(2).
- 023700 05 PUF-3511-VU1Z PIC X(02) OCCURS 5 TIMES.
- 023800 05 PLANT-TYP-3590-VU1Z PIC X.
- 023900 05 OPEN-VU1Z PIC X(7).
- 024000 01 REC-V61Z.
- 024100 05 KEY-V61Z.
- 024200 10 DIC-V61Z.
- 024300 15 REC-TYP-3529-V61Z PIC X(2).
- 024400 15 FMT-NUM-3576-V61Z PIC X(1).
- 024500 15 FMT-CD-3579-V61Z PIC X(1).
- 024600 10 BLM-ADM-U-0003-V61Z.
- 024700 15 BLM-ADM-U-0003-ST-V61Z PIC X(2).
- 024800 15 BLM-ADM-U-0003-DIST-V61Z PIC X(2).
- 024900 15 BLM-ADM-U-0003-RA-V61Z PIC X(2).
- 025000 15 BLM-ADM-U-0003-PLU-V61Z PIC X(2).
- 025100 10 DATA-DATE-6618-V61Z.
- 025200 15 DATA-DATE-6618-YY-V61Z PIC X(2).
- 025300 15 DATA-DATE-6618-MM-V61Z PIC X(2).
- 025400 15 DATA-DATE-6618-DD-V61Z PIC X(2).
- 025500 10 ACTN-CD-7350-V61Z PIC X(1).
- 025600 10 LIN-NUM-3578-V61Z PIC X(4).
- 025700 05 PLANT-CD-2646-V61Z PIC X(7).
- 025800 05 PHNO-STG-CD-3712-V61Z PIC X(1).
- 025900 05 GRAMS-GRN-WGT-3941-V61Z PIC X(4).
- 026000 05 ADW-PCT-3546-V61Z PIC X(3).
- 026100 05 GRAMS-DRY-WGT-3942-V61Z PIC X(4).
- 026200 05 GRP-1-V61Z.
- 026300 07 BASAL-DIMS-3533-MIN-V61Z PIC X(04).
- 026400 07 BASAL-DIMS-3533-MAX-V61Z PIC X(04).
- 026500 07 CROWN-DIMS-3534-MIN-V61Z PIC X(03).
- 026600 07 CROWN-DIMS-3534-MAX-V61Z PIC X(03).
- 026700 07 HGT-AVG-3504-V61Z PIC X(04).
- 026800 07 AVG-LDR-LGT-7313-V61Z PIC X(03).
- 026900 05 PLANT-TYP-3590-V61Z PIC X.
- 027000 05 REC-CNT-V61Z PIC 99.
- 027100*
- 027200 SD SORT-WORK
- 027300 DATA RECORD IS SORT-RCD.
- 027400 01 SORT-RCD.
- 027500 03 SR-KEY.
- 027600 05 REC-TYP-SR PIC XX.
- 027700 05 REC-NUM-CD-SR PIC XX.
- 027800 05 SDRP-SR.
- 027900 07 ST-SR PIC XX.
- 028000 07 DS-SR PIC XX.
- 028100 07 RA-SR PIC XX.
- 028200 07 PU-SR PIC XX.
- 028300 05 LINE-SR PIC XXXX.
- 028400 05 PLANT-CD-SR PIC X(7).
- 028500 05 PHNO-STG-SR PIC X.
- 028600 05 ANML-GZ-CD-SR PIC XX.
- 028700 03 REC-HLD-SR.
- 028800 05 FILLER PIC X(23).
- 028900 05 DATA-V6FP-SR.
- 029000 07 FILLER PIC X.
- 029100 07 DATA-VU-SR PIC X(42).
- 029200 WORKING-STORAGE SECTION.
- 029300 77 END-OF-TRAN PIC X(01) VALUE " ".
- 029400 77 CTL-SAVE PIC X(12) VALUE SPACES.
- 029500 77 END-OF-PREV PIC X(01) VALUE " ".
- 029600 77 LAST-LIN-NUM PIC 9(04) VALUE 0000.
- 029700 77 DATE-SW PIC X(01).
- 029800 77 DATE-MV-SW PIC X(01).
- 029900 77 TODAYS-DATE PIC X(06).
- 030000 01 PARAMETER.
- 030100 03 RELINE-CHK PIC XXX.
- 030200 03 FILLER PIC X(77).
- 030300 01 CTL.
- 030400 03 RECD-ID-C PIC XXXX.
- 030500 03 SDRP-C PIC X(8).
- 030600 01 CTRS.
- 030700 02 VF1-CTR PIC 99999 VALUE 0.
- 030800 02 VP1-CTR PIC 99999 VALUE 0.
- 030900 02 VU1-CTR PIC 99999 VALUE 0.
- 031000 02 V61-CTR PIC 99999 VALUE 0.
- 031100 01 DATE-WORK.
- 031200 02 DW-YY PIC X(02).
- 031300 02 DW-MM PIC X(02).
- 031400 02 DW-DD PIC X(02).
- 031500 01 MOVED-DATE.
- 031600 02 MD-DD PIC XX.
- 031700 02 MD-YY PIC XX.
- 031800 02 MD-MM PIC XX.
- 031900 01 PREV-CTL.
- 032000 03 RECD-ID-PC PIC XXXX.
- 032100 03 SDRP-PC PIC X(8).
- 032200 03 LINE-PC PIC XXXX.
- 032300 01 TRAN-CTL PIC X(16) VALUE SPACE.
- 032400 01 VF1K-RCD.
- 032500 05 KEY-VF1K.
- 032600 10 DIC-VF1K.
- 032700 15 REC-TYP-3529-VF1K PIC X(2).
- 032800 15 FMT-NUM-3576-VF1K PIC X(1).
- 032900 15 FMT-CD-3579-VF1K PIC X(1).
- 033000 10 BLM-ADM-U-0003-VF1K.
- 033100 15 BLM-ADM-U-0003-ST-VF1K PIC X(2).
- 033200 15 BLM-ADM-U-0003-DIST-VF1K PIC X(2).
- 033300 15 FILLER PIC XXXX.
- 033400 10 DATA-DATE-6618-VF1K.
- 033500 15 DATA-DATE-6618-YY-VF1K PIC X(2).
- 033600 15 DATA-DATE-6618-MM-VF1K PIC X(2).
- 033700 15 DATA-DATE-6618-DD-VF1K PIC X(2).
- 033800 10 ACTN-CD-7350-VF1K PIC X(1).
- 033900 10 LIN-NUM-3578-VF1K PIC X(4).
- 034000 05 ANML-GRZG-CD-3929-VF1K PIC X(2).
- 034100 05 MON-FORG-RQMT-LBS-3551-VF1K PIC X(4).
- 034200 05 ANML-HGT-CLS-CD-3548-VF1K PIC X(1).
- 034300 05 FILLER PIC X(36).
- 034400 01 VP1K-RCD.
- 034500 05 KEY-VP1K.
- 034600 10 DIC-VP1K.
- 034700 15 REC-TYP-3529-VP1K PIC X(2).
- 034800 15 FMT-NUM-3576-VP1K PIC X(1).
- 034900 15 FMT-CD-3579-VP1K PIC X(1).
- 035000 10 BLM-ADM-U-0003-VP1K.
- 035100 15 BLM-ADM-U-0003-ST-VP1K PIC X(2).
- 035200 15 BLM-ADM-U-0003-DIST-VP1K PIC X(2).
- 035300 15 BLM-ADM-U-0003-RA-VP1K PIC X(2).
- 035400 15 BLM-ADM-U-0003-PLU-VP1K PIC X(2).
- 035500 10 DATA-DATE-6618-VP1K.
- 035600 15 DATA-DATE-6618-YY-VP1K PIC X(2).
- 035700 15 DATA-DATE-6618-MM-VP1K PIC X(2).
- 035800 15 DATA-DATE-6618-DD-VP1K PIC X(2).
- 035900 10 ACTN-CD-7350-VP1K PIC X(1).
- 036000 10 LIN-NUM-3578-VP1K PIC X(4).
- 036100 05 PLANT-CD-2646-VP1K PIC X(7).
- 036200 05 PHNO-GP-VP1K PIC X(32).
- 036300 05 PHNO-ADJ-GP-VP1K REDEFINES PHNO-GP-VP1K.
- 036400 07 PHNO-ADJ-VP1K OCCURS 8 TIMES.
- 036500 09 PHNO-ADJ-1-VP1K PIC XX.
- 036600 09 PHNO-ADJ-2-VP1K PIC XX.
- 036700 05 PHNO-ADJ-FCTR-3545-VP1K REDEFINES PHNO-GP-VP1K
- 036800 OCCURS 8 TIMES PIC 99V99.
- 036900 05 PLANT-TYP-3590-VP1K PIC X.
- 037000 05 FILLER PIC XXXX.
- 037100 01 VU1K-RCD.
- 037200 05 KEY-VU1K.
- 037300 10 DIC-VU1K.
- 037400 15 REC-TYP-3529-VU1K PIC X(2).
- 037500 15 FMT-NUM-3576-VU1K PIC X(1).
- 037600 15 FMT-CD-3579-VU1K PIC X(1).
- 037700 10 BLM-ADM-U-0003-VU1K.
- 037800 15 BLM-ADM-U-0003-ST-VU1K PIC X(2).
- 037900 15 BLM-ADM-U-0003-DIST-VU1K PIC X(2).
- 038000 15 BLM-ADM-U-0003-RA-VU1K PIC X(2).
- 038100 15 BLM-ADM-U-0003-PLU-VU1K PIC X(2).
- 038200 10 DATA-DATE-6618-VU1K.
- 038300 15 DATA-DATE-6618-YY-VU1K PIC X(2).
- 038400 15 DATA-DATE-6618-MM-VU1K PIC X(2).
- 038500 15 DATA-DATE-6618-DD-VU1K PIC X(2).
- 038600 10 ACTN-CD-7350-VU1K PIC X(1).
- 038700 10 DIET-USE-TYP-3917-VU1K PIC X(1).
- 038800 10 LIN-NUM-3578-VU1K PIC X(4).
- 038900 05 PLANT-CD-2646-VU1K PIC X(7).
- 039000 05 AUF-3928-VU1K-RD PIC X(15).
- 039100 05 AUF-3928-VU1K REDEFINES AUF-3928-VU1K-RD
- 039200 OCCURS 5 TIMES PIC XXX.
- 039300 05 ANML-GRZG-CD-3929-VU1K PIC X(2).
- 039400 05 PUF-3511-VU1K PIC X(02) OCCURS 5 TIMES.
- 039500 05 PLANT-TYP-3590-VU1K PIC X.
- 039600 05 FILLER PIC X(8).
- 039700 01 V61K-RCD.
- 039800 05 KEY-V61K.
- 039900 10 DIC-V61K.
- 040000 15 REC-TYP-3529-V61K PIC X(2).
- 040100 15 FMT-NUM-3576-V61K PIC X(1).
- 040200 15 FMT-CD-3579-V61K PIC X(1).
- 040300 10 BLM-ADM-U-0003-V61K.
- 040400 15 BLM-ADM-U-0003-ST-V61K PIC X(2).
- 040500 15 BLM-ADM-U-0003-DIST-V61K PIC X(2).
- 040600 15 BLM-ADM-U-0003-RA-V61K PIC X(2).
- 040700 15 BLM-ADM-U-0003-PLU-V61K PIC X(2).
- 040800 10 DATA-DATE-6618-V61K.
- 040900 15 DATA-DATE-6618-YY-V61K PIC X(2).
- 041000 15 DATA-DATE-MM-6618-V61K PIC XX.
- 041100 15 DATA-DATE-6618-DD-V61K PIC X(2).
- 041200 10 ACTN-CD-7350-V61K PIC X(1).
- 041300 10 LIN-NUM-3578-V61K PIC X(4).
- 041400 05 PLANT-CD-2646-V61K PIC X(7).
- 041500 05 PHNO-STG-CD-3712-V61K PIC X(1).
- 041600 05 GRAMS-GRN-WGT-3941-V61K PIC X(4).
- 041700 05 ADW-PCT-3546-V61K PIC X(3).
- 041800 05 GRAMS-DRY-WGT-3942-V61K PIC X(4).
- 041900 05 GRP-1-V61K.
- 042000 07 BASAL-DIMS-3533-MIN-V61K PIC XXXX.
- 042100 07 BASAL-DIMS-3533-MAX-V61K PIC XXXX.
- 042200 07 CROWN-DIMS-3534-MIN-V61K PIC XXX.
- 042300 07 CROWN-DIMS-3534-MAX-V61K PIC XXX.
- 042400 07 HGT-AVG-3504-V61K PIC XXXX.
- 042500 07 AVG-LDR-LGT-7313-V61K PIC XXX.
- 042600 05 PLANT-TYP-3590-V61K PIC X.
- 042700 05 REC-CNT-V61K PIC 99.
- 042800 PROCEDURE DIVISION.
- 042900 000-DRIVER SECTION.
- 043000 010-MAINLINE.
- 043100 PERFORM 100-INITIALIZE.
- 043200 PERFORM 200-SORT.
- 043300 PERFORM 990-TERMINATE.
- 043400 STOP RUN.
- 043500*
- 043600 100-INITIALIZE SECTION.
- 043700 110-OPENS.
- 043800 OPEN INPUT PREV-FILE TRAN-FILE
- 043900 OUTPUT NEW-FILE.
- 044000 MOVE ALL "9" TO PREV-CTL.
- 044100 ACCEPT TODAYS-DATE FROM DATE.
- 044200 ACCEPT PARAMETER.
- 044300*
- 044400 200-SORT SECTION.
- 044500 210-SORT-VERB.
- 044600 SORT SORT-WORK
- 044700 ASCENDING KEY SR-KEY
- 044800 INPUT PROCEDURE 300-READ-FORMAT
- 044900 OUTPUT PROCEDURE 400-MATCH-UPDATE.
- 045000*
- 045100 300-READ-FORMAT SECTION.
- 045200 310-READ.
- 045300 READ TRAN-FILE
- 045400 AT END GO TO 300-EXIT.
- 045500 IF REC-TYP-TF NOT = "VP" AND "VU" AND "VF" AND "V6"
- 045600 DISPLAY "BAD-RCD= " TF-RCD
- 045700 GO TO 310-READ.
- 045800 IF ACTN-TF = SPACE
- 045900 MOVE "A" TO ACTN-TF.
- 046000 IF (REC-TYP-TF = "VU") AND
- 046100 ((LINE-VU-TF NOT NUMERIC) OR
- 046200 (LINE-VU-TF = "0000")
- 046300 OR (RELINE-CHK = "YES"))
- 046400 MOVE ALL "9" TO LINE-VU-TF.
- 046500 IF (REC-TYP-TF NOT = "VU") AND
- 046600 ((LINE-TF NOT NUMERIC) OR
- 046700 (LINE-TF = "0000")
- 046800 OR (RELINE-CHK = "YES"))
- 046900 MOVE ALL "9" TO LINE-TF.
- 047000 MOVE TF-RCD TO REC-HLD-SR.
- 047100 MOVE SPACE TO SR-KEY.
- 047200 MOVE REC-TYP-TF TO REC-TYP-SR.
- 047300 MOVE REC-NUM-CD-TF TO REC-NUM-CD-SR.
- 047400 MOVE SDRP-TF TO SDRP-SR.
- 047500 IF REC-TYP-TF = "VU"
- 047600 MOVE LINE-VU-TF TO LINE-SR
- 047700 MOVE PLANT-CD-VU-TF TO PLANT-CD-SR
- 047800 MOVE ANML-GZ-CD-VU-TF TO ANML-GZ-CD-SR
- 047900 ELSE
- 048000 MOVE LINE-TF TO LINE-SR.
- 048100 IF REC-TYP-TF = "VP" OR "V6"
- 048200 MOVE PLANT-CD-TF TO PLANT-CD-SR
- 048300 MOVE PHNO-STG-TF TO PHNO-STG-SR.
- 048400 IF REC-TYP-TF = "VF"
- 048500 MOVE ANML-GZ-CD-VF-TF TO ANML-GZ-CD-SR.
- 048600 RELEASE SORT-RCD.
- 048700 GO TO 310-READ.
- 048800 300-EXIT.
- 048900 EXIT.
- 049000*
- 049100 400-MATCH-UPDATE SECTION.
- 049200 410-GET-FIRST-RCDS.
- 049300 PERFORM 430-RETURN-SORT.
- 049400 PERFORM 440-READ-PREV.
- 049500 420-COMPARE.
- 049600 IF TRAN-CTL IS EQUAL TO ALL "9" AND
- 049700 PREV-CTL IS EQUAL TO ALL "9"
- 049800 GO TO 400-EXIT.
- 049900 IF TRAN-CTL IS GREATER THAN PREV-CTL
- 050000 PERFORM 500-NO-TRAN
- 050100 GO TO 420-COMPARE.
- 050200 IF PREV-CTL IS GREATER THAN TRAN-CTL
- 050300 PERFORM 600-NO-PREV
- 050400 GO TO 420-COMPARE.
- 050500 IF TRAN-CTL IS EQUAL TO PREV-CTL
- 050600 PERFORM 700-MATCH.
- 050700 GO TO 420-COMPARE.
- 050800 430-RETURN-SORT.
- 050900 RETURN SORT-WORK AT END
- 051000 MOVE "X" TO END-OF-TRAN.
- 051100 IF REC-TYP-SR IS EQUAL TO "VF"
- 051200 MOVE REC-HLD-SR TO VF1K-RCD.
- 051300 IF REC-TYP-SR IS EQUAL TO "VP"
- 051400 MOVE REC-HLD-SR TO VP1K-RCD.
- 051500 IF REC-TYP-SR IS EQUAL TO "VU"
- 051600 MOVE REC-HLD-SR TO VU1K-RCD.
- 051700 IF REC-TYP-SR IS EQUAL TO "V6"
- 051800 MOVE REC-HLD-SR TO V61K-RCD.
- 051900 MOVE SR-KEY TO TRAN-CTL.
- 052000 IF END-OF-TRAN IS EQUAL TO "X"
- 052100 MOVE ALL "9" TO TRAN-CTL.
- 052200 440-READ-PREV.
- 052300 READ PREV-FILE AT END
- 052400 MOVE "X" TO END-OF-PREV.
- 052500 MOVE DIC-VF1X TO RECD-ID-PC.
- 052600 MOVE BLM-ADM-U-0003-VF1X TO SDRP-PC.
- 052700 MOVE LIN-NUM-3578-VF1X TO LINE-PC.
- 052800 IF REC-TYP-3529-VP1X = "VU"
- 052900 MOVE LIN-NUM-3578-VU1X TO LINE-PC.
- 053000 IF END-OF-PREV = "X"
- 053100 MOVE ALL "9" TO PREV-CTL.
- 053200 500-NO-TRAN.
- 053300 MOVE VF1X-RCD TO VF1Z-RCD.
- 053400 PERFORM 800-ADD-TO-CTRS.
- 053500 PERFORM 920-WRITE-Z-RCD.
- 053600 IF END-OF-PREV NOT = "X"
- 053700 PERFORM 440-READ-PREV.
- 053800 600-NO-PREV.
- 053900 MOVE REC-HLD-SR TO VF1Z-RCD.
- 054000 PERFORM 800-ADD-TO-CTRS.
- 054100 IF REC-TYP-3529-VF1Z = "VF"
- 054200 PERFORM 810-BUILD-VF-LIN-NUM
- 054300 PERFORM 830-CHECK-VF-LIN-NUM THRU 830-OUT.
- 054400 IF REC-TYP-3529-VF1Z = "VP"
- 054500 PERFORM 820-BUILD-VP-LIN-NUM
- 054600 PERFORM 840-CHECK-VP-LIN-NUM THRU 840-OUT.
- 054700 IF REC-TYP-3529-VF1Z = "VU"
- 054800 PERFORM 815-BUILD-VU-LIN-NUM
- 054900 PERFORM 825-CHECK-VU-LIN-NUM THRU 825-OUT.
- 055000 IF REC-TYP-3529-VF1Z = "V6"
- 055100 PERFORM 835-BUILD-V6-LIN-NUM
- 055200 PERFORM 845-CHECK-V6-LIN-NUM THRU 845-OUT.
- 055300 PERFORM 890-EDIT-DATE.
- 055400 PERFORM 920-WRITE-Z-RCD.
- 055500 IF END-OF-TRAN NOT = "X"
- 055600 PERFORM 430-RETURN-SORT.
- 055700 700-MATCH.
- 055800 MOVE VF1X-RCD TO VF1Z-RCD.
- 055900 PERFORM 890-EDIT-DATE.
- 056000 IF (DATA-V6FP-SR NOT = SPACES)
- 056100 AND (REC-TYP-3529-VF1Z = "VF")
- 056200 PERFORM 850-MOVE-VF-FIELDS
- 056300 PERFORM 810-BUILD-VF-LIN-NUM
- 056400 PERFORM 800-ADD-TO-CTRS
- 056500 PERFORM 920-WRITE-Z-RCD.
- 056600 IF (DATA-V6FP-SR NOT = SPACES)
- 056700 AND (REC-TYP-3529-VF1Z = "VP")
- 056800 PERFORM 860-MOVE-VP1-FIELDS
- 056900 PERFORM 820-BUILD-VP-LIN-NUM
- 057000 PERFORM 800-ADD-TO-CTRS
- 057100 PERFORM 920-WRITE-Z-RCD.
- 057200 IF (DATA-VU-SR NOT = SPACES)
- 057300 AND (REC-TYP-3529-VF1Z = "VU" )
- 057400 PERFORM 870-MOVE-VU1-FIELDS
- 057500 PERFORM 815-BUILD-VU-LIN-NUM
- 057600 PERFORM 800-ADD-TO-CTRS
- 057700 PERFORM 920-WRITE-Z-RCD.
- 057800 IF (DATA-V6FP-SR NOT = SPACES)
- 057900 AND (REC-TYP-3529-VF1Z = "V6")
- 058000 PERFORM 880-MOVE-V61-FIELDS
- 058100 PERFORM 835-BUILD-V6-LIN-NUM
- 058200 PERFORM 800-ADD-TO-CTRS
- 058300 PERFORM 920-WRITE-Z-RCD.
- 058400 IF END-OF-TRAN NOT = "X"
- 058500 PERFORM 430-RETURN-SORT.
- 058600 IF END-OF-PREV NOT = "X"
- 058700 PERFORM 440-READ-PREV.
- 058800*
- 058900 800-ADD-TO-CTRS.
- 059000 IF REC-TYP-3529-VF1Z = "VF"
- 059100 ADD 1 TO VF1-CTR
- 059200 PERFORM 810-BUILD-VF-LIN-NUM.
- 059300 IF REC-TYP-3529-VF1Z = "VP"
- 059400 PERFORM 820-BUILD-VP-LIN-NUM
- 059500 ADD 1 TO VP1-CTR.
- 059600 IF REC-TYP-3529-VF1Z = "VU"
- 059700 PERFORM 815-BUILD-VU-LIN-NUM
- 059800 ADD 1 TO VU1-CTR.
- 059900 IF REC-TYP-3529-VF1Z = "V6"
- 060000 PERFORM 835-BUILD-V6-LIN-NUM
- 060100 ADD 1 TO V61-CTR.
- 060200*
- 060300 810-BUILD-VF-LIN-NUM.
- 060400 IF (LIN-NUM-3578-VF1Z NOT NUMERIC) OR
- 060500 (LIN-NUM-3578-VF1Z = "0000")
- 060600 MOVE "9999" TO LIN-NUM-3578-VF1Z.
- 060700 815-BUILD-VU-LIN-NUM.
- 060800 IF (LIN-NUM-3578-VU1Z NOT NUMERIC) OR
- 060900 (LIN-NUM-3578-VU1Z = "0000")
- 061000 MOVE "9999" TO LIN-NUM-3578-VU1Z.
- 061100 820-BUILD-VP-LIN-NUM.
- 061200 IF (LIN-NUM-3578-VP1Z NOT NUMERIC) OR
- 061300 (LIN-NUM-3578-VP1Z = "0000")
- 061400 MOVE "9999" TO LIN-NUM-3578-VP1Z.
- 061500 825-CHECK-VU-LIN-NUM.
- 061600 IF LIN-NUM-3578-VU1Z NOT = "9999"
- 061700 GO TO 825-OUT.
- 061800 MOVE DIC-VF1Z TO RECD-ID-C.
- 061900 MOVE BLM-ADM-U-0003-VF1Z TO SDRP-C.
- 062000 IF CTL NOT = CTL-SAVE
- 062100 MOVE 0001 TO LAST-LIN-NUM
- 062200 MOVE "0001" TO LIN-NUM-3578-VU1Z
- 062300 ELSE ADD 1 TO LAST-LIN-NUM
- 062400 MOVE LAST-LIN-NUM TO LIN-NUM-3578-VU1Z.
- 062500 MOVE CTL TO CTL-SAVE.
- 062600 825-OUT.
- 062700 EXIT.
- 062800 830-CHECK-VF-LIN-NUM.
- 062900 IF LIN-NUM-3578-VF1Z NOT = ALL "9"
- 063000 GO TO 830-OUT.
- 063100 MOVE DIC-VF1Z TO RECD-ID-C.
- 063200 MOVE BLM-ADM-U-0003-VF1Z TO SDRP-C.
- 063300 IF CTL NOT = CTL-SAVE
- 063400 MOVE 0001 TO LAST-LIN-NUM
- 063500 MOVE "0001" TO LIN-NUM-3578-VF1Z
- 063600 ELSE
- 063700 ADD 1 TO LAST-LIN-NUM
- 063800 MOVE LAST-LIN-NUM TO LIN-NUM-3578-VF1Z.
- 063900 MOVE CTL TO CTL-SAVE.
- 064000 830-OUT.
- 064100 EXIT.
- 064200 835-BUILD-V6-LIN-NUM.
- 064300 IF (LIN-NUM-3578-V61Z NOT NUMERIC) OR
- 064400 (LIN-NUM-3578-V61Z = "0000")
- 064500 MOVE "9999" TO LIN-NUM-3578-V61Z.
- 064600 840-CHECK-VP-LIN-NUM.
- 064700 IF LIN-NUM-3578-VP1Z NOT = ALL "9"
- 064800 GO TO 840-OUT.
- 064900 MOVE DIC-VP1Z TO RECD-ID-C.
- 065000 MOVE BLM-ADM-U-0003-VP1Z TO SDRP-C.
- 065100 IF CTL NOT = CTL-SAVE
- 065200 MOVE 0001 TO LAST-LIN-NUM
- 065300 MOVE "0001" TO LIN-NUM-3578-VP1Z
- 065400 ELSE
- 065500 ADD 1 TO LAST-LIN-NUM
- 065600 MOVE LAST-LIN-NUM TO LIN-NUM-3578-VP1Z.
- 065700 MOVE CTL TO CTL-SAVE.
- 065800 840-OUT.
- 065900 EXIT.
- 066000 845-CHECK-V6-LIN-NUM.
- 066100 IF LIN-NUM-3578-V61Z NOT = "9999"
- 066200 GO TO 845-OUT.
- 066300 MOVE DIC-VF1Z TO RECD-ID-C.
- 066400 MOVE BLM-ADM-U-0003-VF1Z TO SDRP-C.
- 066500 IF CTL NOT = TO CTL-SAVE
- 066600 MOVE 0001 TO LAST-LIN-NUM
- 066700 MOVE "0001" TO LIN-NUM-3578-V61Z
- 066800 ELSE ADD 1 TO LAST-LIN-NUM
- 066900 MOVE LAST-LIN-NUM TO LIN-NUM-3578-V61Z.
- 067000 MOVE CTL TO CTL-SAVE.
- 067100 845-OUT.
- 067200 EXIT.
- 067300*
- 067400 850-MOVE-VF-FIELDS.
- 067500 IF ANML-GRZG-CD-3929-VF1K = SPACES
- 067600 NEXT SENTENCE
- 067700 ELSE
- 067800 IF ANML-GRZG-CD-3929-VF1K = "**"
- 067900 MOVE SPACES TO ANML-GRZG-CD-3929-VF1Z
- 068000 ELSE
- 068100 MOVE ANML-GRZG-CD-3929-VF1K TO ANML-GRZG-CD-3929-VF1Z.
- 068200 IF MON-FORG-RQMT-LBS-3551-VF1K = SPACES
- 068300 NEXT SENTENCE
- 068400 ELSE
- 068500 IF MON-FORG-RQMT-LBS-3551-VF1K = "**"
- 068600 MOVE SPACES TO MON-FORG-RQMT-LBS-3551-VF1Z
- 068700 MOVE MON-FORG-RQMT-LBS-3551-VF1K TO
- 068800 MON-FORG-RQMT-LBS-3551-VF1Z.
- 068900 IF ANML-HGT-CLS-CD-3548-VF1K = SPACES
- 069000 NEXT SENTENCE
- 069100 ELSE
- 069200 IF ANML-HGT-CLS-CD-3548-VF1K = "*"
- 069300 MOVE SPACES TO ANML-HGT-CLS-CD-3548-VF1Z
- 069400 ELSE
- 069500 MOVE ANML-HGT-CLS-CD-3548-VF1K TO ANML-HGT-CLS-CD-3548-VF1Z.
- 069600 870-MOVE-VU1-FIELDS.
- 069700 IF PLANT-CD-2646-VU1K = SPACES
- 069800 NEXT SENTENCE
- 069900 ELSE
- 070000 IF PLANT-CD-2646-VU1K = "*******"
- 070100 MOVE SPACES TO PLANT-CD-2646-VU1Z
- 070200 ELSE
- 070300 MOVE PLANT-CD-2646-VU1K TO PLANT-CD-2646-VU1Z.
- 070400 IF AUF-3928-VU1K (1) = SPACES
- 070500 NEXT SENTENCE
- 070600 ELSE
- 070700 IF AUF-3928-VU1K (1) = "**"
- 070800 MOVE SPACES TO AUF-3928-VU1Z (1)
- 070900 ELSE
- 071000 MOVE AUF-3928-VU1K (1) TO AUF-3928-VU1Z (1).
- 071100 IF AUF-3928-VU1K (2) = SPACES
- 071200 NEXT SENTENCE
- 071300 ELSE
- 071400 IF AUF-3928-VU1K (2) = "**"
- 071500 MOVE SPACES TO AUF-3928-VU1Z (2)
- 071600 ELSE
- 071700 MOVE AUF-3928-VU1K (2) TO AUF-3928-VU1Z (2).
- 071800 IF AUF-3928-VU1K (3) = SPACES
- 071900 NEXT SENTENCE
- 072000 ELSE
- 072100 IF AUF-3928-VU1K (3) = "**"
- 072200 MOVE SPACES TO AUF-3928-VU1Z (3)
- 072300 ELSE
- 072400 MOVE AUF-3928-VU1K (3) TO AUF-3928-VU1Z (3).
- 072500 IF AUF-3928-VU1K (4) = SPACES
- 072600 NEXT SENTENCE
- 072700 ELSE
- 072800 IF AUF-3928-VU1K (4) = "**"
- 072900 MOVE SPACES TO AUF-3928-VU1Z (4)
- 073000 ELSE
- 073100 MOVE AUF-3928-VU1K (4) TO AUF-3928-VU1Z (4).
- 073200 IF AUF-3928-VU1K (5) = SPACES
- 073300 NEXT SENTENCE
- 073400 ELSE
- 073500 IF AUF-3928-VU1K (5) = "**"
- 073600 MOVE SPACES TO AUF-3928-VU1Z (5)
- 073700 ELSE
- 073800 MOVE AUF-3928-VU1K (5) TO AUF-3928-VU1Z (5).
- 073900 IF ANML-GRZG-CD-3929-VU1K = SPACES
- 074000 NEXT SENTENCE
- 074100 ELSE
- 074200 IF ANML-GRZG-CD-3929-VU1K = "**"
- 074300 MOVE SPACES TO ANML-GRZG-CD-3929-VU1Z
- 074400 ELSE
- 074500 MOVE ANML-GRZG-CD-3929-VU1K TO ANML-GRZG-CD-3929-VU1Z.
- 074600 IF PUF-3511-VU1K (1) = SPACES
- 074700 NEXT SENTENCE
- 074800 ELSE
- 074900 IF PUF-3511-VU1K (1) = "**"
- 075000 MOVE SPACES TO PUF-3511-VU1Z (1)
- 075100 ELSE
- 075200 MOVE PUF-3511-VU1K (1) TO PUF-3511-VU1Z (1).
- 075300 IF PUF-3511-VU1K (2) = SPACES
- 075400 NEXT SENTENCE
- 075500 ELSE
- 075600 IF PUF-3511-VU1K (2) = "**"
- 075700 MOVE SPACES TO PUF-3511-VU1Z (2)
- 075800 ELSE
- 075900 MOVE PUF-3511-VU1K (2) TO PUF-3511-VU1Z (2).
- 076000 IF PUF-3511-VU1K (3) = SPACES
- 076100 NEXT SENTENCE
- 076200 ELSE
- 076300 IF PUF-3511-VU1K (3) = "**"
- 076400 MOVE SPACES TO PUF-3511-VU1Z (3)
- 076500 ELSE
- 076600 MOVE PUF-3511-VU1K (3) TO PUF-3511-VU1Z (3).
- 076700 IF PUF-3511-VU1K (4) = SPACES
- 076800 NEXT SENTENCE
- 076900 ELSE
- 077000 IF PUF-3511-VU1K (4) = "**"
- 077100 MOVE SPACES TO PUF-3511-VU1Z (4)
- 077200 ELSE
- 077300 MOVE PUF-3511-VU1K (4) TO PUF-3511-VU1Z (4).
- 077400 IF PUF-3511-VU1K (5) = SPACES
- 077500 NEXT SENTENCE
- 077600 ELSE
- 077700 IF PUF-3511-VU1K (5) = "**"
- 077800 MOVE SPACES TO PUF-3511-VU1Z (5)
- 077900 ELSE
- 078000 MOVE PUF-3511-VU1K (5) TO PUF-3511-VU1Z (5).
- 078100 860-MOVE-VP1-FIELDS.
- 078200 IF PLANT-TYP-3590-VP1K = SPACES
- 078300 NEXT SENTENCE
- 078400 ELSE
- 078500 IF PLANT-TYP-3590-VP1K = "*"
- 078600 MOVE SPACES TO PLANT-TYP-3590-VP1Z
- 078700 ELSE
- 078800 MOVE PLANT-TYP-3590-VP1K TO
- 078900 PLANT-TYP-3590-VP1Z.
- 079000 IF PLANT-CD-2646-VP1K = SPACES
- 079100 NEXT SENTENCE
- 079200 ELSE
- 079300 IF PLANT-CD-2646-VP1K = "*******"
- 079400 MOVE SPACES TO PLANT-CD-2646-VP1Z
- 079500 ELSE
- 079600 MOVE PLANT-CD-2646-VP1K TO PLANT-CD-2646-VP1Z.
- 079700 IF PHNO-ADJ-VP1K (1) = SPACES
- 079800 NEXT SENTENCE
- 079900 ELSE
- 080000 IF PHNO-ADJ-VP1K (1) = "****"
- 080100 MOVE SPACES TO PHNO-ADJ-VP1Z (1)
- 080200 ELSE
- 080300 MOVE PHNO-ADJ-VP1K (1) TO
- 080400 PHNO-ADJ-VP1Z (1).
- 080500 IF PHNO-ADJ-VP1K (2) = SPACES
- 080600 NEXT SENTENCE
- 080700 ELSE
- 080800 IF PHNO-ADJ-VP1K (2) = "****"
- 080900 MOVE SPACES TO PHNO-ADJ-VP1Z (2)
- 081000 ELSE
- 081100 MOVE PHNO-ADJ-VP1K (2) TO
- 081200 PHNO-ADJ-VP1Z (2).
- 081300 IF PHNO-ADJ-VP1K (3) = SPACES
- 081400 NEXT SENTENCE
- 081500 ELSE
- 081600 IF PHNO-ADJ-VP1K (3) = "****"
- 081700 MOVE SPACES TO PHNO-ADJ-VP1Z (3)
- 081800 ELSE
- 081900 MOVE PHNO-ADJ-VP1K (3) TO
- 082000 PHNO-ADJ-VP1Z (3).
- 082100 IF PHNO-ADJ-VP1K (4) = SPACES
- 082200 NEXT SENTENCE
- 082300 ELSE
- 082400 IF PHNO-ADJ-VP1K (4) = "****"
- 082500 MOVE SPACES TO PHNO-ADJ-VP1Z (4)
- 082600 ELSE
- 082700 MOVE PHNO-ADJ-VP1K (4) TO
- 082800 PHNO-ADJ-VP1Z (4).
- 082900 IF PHNO-ADJ-VP1K (5) = SPACES
- 083000 NEXT SENTENCE
- 083100 ELSE
- 083200 IF PHNO-ADJ-VP1K (5) = "****"
- 083300 MOVE SPACES TO PHNO-ADJ-VP1Z (5)
- 083400 ELSE
- 083500 MOVE PHNO-ADJ-VP1K (5) TO
- 083600 PHNO-ADJ-VP1Z (5).
- 083700 880-MOVE-V61-FIELDS.
- 083800 IF PLANT-CD-2646-V61K = SPACES
- 083900 NEXT SENTENCE
- 084000 ELSE
- 084100 IF PLANT-CD-2646-V61K = "*****"
- 084200 MOVE SPACES TO PLANT-CD-2646-V61Z
- 084300 ELSE
- 084400 MOVE PLANT-CD-2646-V61K TO PLANT-CD-2646-V61Z.
- 084500 IF PHNO-STG-CD-3712-V61K = SPACES
- 084600 NEXT SENTENCE
- 084700 ELSE
- 084800 IF PHNO-STG-CD-3712-V61K = "*"
- 084900 MOVE SPACES TO PHNO-STG-CD-3712-V61Z
- 085000 ELSE
- 085100 MOVE PHNO-STG-CD-3712-V61K TO PHNO-STG-CD-3712-V61Z.
- 085200 IF GRAMS-GRN-WGT-3941-V61K = SPACES
- 085300 NEXT SENTENCE
- 085400 ELSE
- 085500 IF GRAMS-GRN-WGT-3941-V61K = "****"
- 085600 MOVE SPACES TO GRAMS-GRN-WGT-3941-V61Z
- 085700 ELSE
- 085800 MOVE GRAMS-GRN-WGT-3941-V61K TO GRAMS-GRN-WGT-3941-V61Z.
- 085900 IF ADW-PCT-3546-V61K = SPACES
- 086000 NEXT SENTENCE
- 086100 ELSE
- 086200 IF ADW-PCT-3546-V61K = "***"
- 086300 MOVE SPACES TO ADW-PCT-3546-V61Z
- 086400 ELSE
- 086500 MOVE ADW-PCT-3546-V61K TO ADW-PCT-3546-V61Z.
- 086600 IF BASAL-DIMS-3533-MIN-V61K = SPACES
- 086700 NEXT SENTENCE
- 086800 ELSE
- 086900 IF BASAL-DIMS-3533-MIN-V61K = "****"
- 087000 MOVE SPACES TO BASAL-DIMS-3533-MIN-V61Z
- 087100 ELSE
- 087200 MOVE BASAL-DIMS-3533-MIN-V61K TO BASAL-DIMS-3533-MIN-V61Z
- 087300 IF BASAL-DIMS-3533-MAX-V61K = SPACES
- 087400 NEXT SENTENCE
- 087500 ELSE
- 087600 IF BASAL-DIMS-3533-MAX-V61K = "****"
- 087700 MOVE SPACES TO BASAL-DIMS-3533-MAX-V61Z
- 087800 ELSE
- 087900 MOVE BASAL-DIMS-3533-MAX-V61K TO BASAL-DIMS-3533-MAX-V61Z
- 088000 IF CROWN-DIMS-3534-MIN-V61K = SPACES
- 088100 NEXT SENTENCE
- 088200 ELSE
- 088300 IF CROWN-DIMS-3534-MIN-V61K = "***"
- 088400 MOVE SPACES TO CROWN-DIMS-3534-MIN-V61Z
- 088500 ELSE
- 088600 MOVE CROWN-DIMS-3534-MIN-V61K TO CROWN-DIMS-3534-MIN-V61Z
- 088700 IF CROWN-DIMS-3534-MAX-V61K = SPACES
- 088800 NEXT SENTENCE
- 088900 ELSE
- 089000 IF CROWN-DIMS-3534-MAX-V61K = "***"
- 089100 MOVE SPACES TO CROWN-DIMS-3534-MAX-V61Z
- 089200 ELSE
- 089300 MOVE CROWN-DIMS-3534-MAX-V61K TO CROWN-DIMS-3534-MAX-V61Z
- 089400 IF HGT-AVG-3504-V61K = SPACES
- 089500 NEXT SENTENCE
- 089600 ELSE
- 089700 IF HGT-AVG-3504-V61K = "****"
- 089800 MOVE SPACES TO HGT-AVG-3504-V61Z
- 089900 ELSE
- 090000 MOVE HGT-AVG-3504-V61K TO HGT-AVG-3504-V61Z.
- 090100 IF AVG-LDR-LGT-7313-V61K = SPACES
- 090200 NEXT SENTENCE
- 090300 ELSE
- 090400 IF AVG-LDR-LGT-7313-V61K = "***"
- 090500 MOVE SPACES TO AVG-LDR-LGT-7313-V61Z
- 090600 ELSE
- 090700 MOVE AVG-LDR-LGT-7313-V61K TO AVG-LDR-LGT-7313-V61Z.
- 090800 IF PLANT-CD-2646-V61K = SPACES
- 090900 NEXT SENTENCE
- 091000 ELSE
- 091100 IF PLANT-CD-2646-V61K = "*****"
- 091200 MOVE SPACES TO PLANT-CD-2646-V61Z
- 091300 ELSE
- 091400 MOVE PLANT-CD-2646-V61K TO PLANT-CD-2646-V61Z.
- 091500 MOVE REC-CNT-V61K TO REC-CNT-V61Z.
- 091600*
- 091700 890-EDIT-DATE.
- 091800 MOVE SPACE TO DATE-MV-SW.
- 091900 MOVE DATA-DATE-6618-VP1Z TO DATE-WORK.
- 092000 PERFORM 900-EDIT-FIELDS.
- 092100 IF DATE-SW NOT = " "
- 092200 PERFORM 910-SWITCH-FIELDS
- 092300 PERFORM 900-EDIT-FIELDS.
- 092400 IF DATE-SW NOT = " "
- 092500 MOVE TODAYS-DATE TO DATA-DATE-6618-VF1Z.
- 092600 IF DATE-MV-SW NOT = " "
- 092700 MOVE MOVED-DATE TO DATA-DATE-6618-VF1Z.
- 092800 900-EDIT-FIELDS.
- 092900 MOVE SPACE TO DATE-SW.
- 093000 IF DW-MM NOT NUMERIC OR
- 093100 DW-MM > "12" OR
- 093200 DW-MM < "01"
- 093300 MOVE "X" TO DATE-SW.
- 093400 IF DW-DD NOT NUMERIC OR
- 093500 DW-DD < "01" OR
- 093600 DW-DD > "31"
- 093700 MOVE "X" TO DATE-SW.
- 093800 IF DW-YY NOT NUMERIC OR
- 093900 DW-YY < "78"
- 094000 MOVE "X" TO DATE-SW.
- 094100 910-SWITCH-FIELDS.
- 094200 MOVE " " TO DATE-MV-SW.
- 094300 IF DW-DD = "78" OR "79" OR "80" OR "81" OR "82"
- 094400 MOVE DW-MM TO MD-MM
- 094500 MOVE DW-DD TO MD-DD
- 094600 MOVE DW-YY TO MD-YY
- 094700 MOVE "X" TO DATE-MV-SW.
- 094800 920-WRITE-Z-RCD.
- 094900 MOVE LIN-NUM-3578-VP1Z TO LAST-LIN-NUM.
- 095000 IF REC-TYP-3529-VF1Z = "VU"
- 095100 MOVE LIN-NUM-3578-VU1Z TO LAST-LIN-NUM.
- 095200 MOVE DIC-VP1Z TO RECD-ID-C.
- 095300 MOVE BLM-ADM-U-0003-VP1Z TO SDRP-C.
- 095400 IF REC-TYP-3529-VF1Z = "VF" MOVE SPACES TO OPEN-VF1Z.
- 095500 IF REC-TYP-3529-VF1Z = "VP" MOVE SPACES TO OPEN-VP1Z.
- 095600 IF REC-TYP-3529-VF1Z = "VU" MOVE SPACES TO OPEN-VU1Z.
- 095700 MOVE CTL TO CTL-SAVE.
- 095800 MOVE "A" TO ACTN-CD-7350-VF1Z.
- 095900 WRITE VF1Z-RCD.
- 096000 400-EXIT.
- 096100 EXIT.
- 096200*
- 096300 990-TERMINATE SECTION.
- 096400 990-PRINT.
- 096500 DISPLAY " VF1 VP1 VU1 V61".
- 096600 DISPLAY VF1-CTR " " VP1-CTR " " VU1-CTR " " V61-CTR.
- 096700 990-CLOSE.
- 096800 CLOSE PREV-FILE TRAN-FILE NEW-FILE.
- 096900*
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES115P.
- 000300* V6, VF, VP, VU VERIFICATION LIST
- 000400*
- 000500 AUTHOR. CORA FISCHER.
- 000500 INSTALLATION.
- 000600 DATE-WRITTEN. 7/10/80.
- 000700 DATE-COMPILED.
- 000800 ENVIRONMENT DIVISION.
- 000900 CONFIGURATION SECTION.
- 001000 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001100 OBJECT-COMPUTER. LEVEL-66-ASCII.
- 001200 INPUT-OUTPUT SECTION.
- 001300 FILE-CONTROL.
- 001400 SELECT INPUT-FILE1 ASSIGN TO I1-ES110UD1
- 001500 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001600 SELECT OPTIONAL INPUT-FILE2 ASSIGN TO I2-ES120UD1
- 001700 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001800 SELECT PRINT-FILE ASSIGN TO P1-PRINTER
- 001900 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002000 SELECT SORT-FILE ASSIGN TO S1.
- 002100 DATA DIVISION.
- 002200 SUB-SCHEMA SECTION.
- 002300 DB CODVAL2 WITHIN BLMDIC.
- 002400 FILE SECTION.
- 002500 FD INPUT-FILE1 CODE-SET IS GBCD
- 002600 LABEL RECORDS ARE STANDARD
- 002700 DATA RECORDS ARE FDR-V6 FDR-VF
- 002800 FDR-VP FDR-VU.
- 002900 01 FDR-V6.
- 003000 03 REC-TYPE-3529-V6-I1 PIC X(02).
- 003100 03 FMT-NO-3576-V6-I1 PIC X(01).
- 003200 03 FMT-CD-3579-V6-I1 PIC X(01).
- 003300 03 ADM-UNIT-0003-V6-I1 PIC X(08).
- 003400 03 DATA-DT-6618-V6-I1 PIC X(06).
- 003500 03 ACT-CD-7350-V6-I1 PIC X(01).
- 003600 03 LINE-NO-3578-V6-I1 PIC X(04).
- 003700 03 PLANT-CD-2646-V6-I1 PIC X(07).
- 003800 03 PHNO-STG-CD-3712-V6-I1 PIC X(01).
- 003900 03 GRAMS-GRN-WGT-3941-V6-I1 PIC X(04).
- 004000 03 ADW-PCT-3546-V6-I1 PIC X(03).
- 004100 03 GRAMS-DRY-WGT-3942-V6-I1 PIC X(04).
- 004200 03 BASAL-DIMS-3533-V6-I1 PIC X(08).
- 004300 03 CROWN-DIMS-3534-V6-I1 PIC X(06).
- 004400 03 HGT-AVG-3504-V6-I1 PIC X(04).
- 004500 03 AVG-LDR-LGT-7313-V6-I1 PIC X(03).
- 004600 03 FILLER PIC X(03).
- 004700 01 FDR-VF.
- 004800 03 REC-TYPE-3529-VF-I1 PIC X(02).
- 004900 03 FMT-NO-3576-VF-I1 PIC X(01).
- 005000 03 FMT-CD-3579-VF-I1 PIC X(01).
- 005100 03 ADM-UNIT-0003-VF-I1.
- 005200 05 ADM-ST-0003-VF-I1 PIC X(02).
- 005300 05 ADM-DI-0003-VF-I1 PIC X(02).
- 005400 05 ADM-RA-0003-VF-I1 PIC X(02).
- 005500 05 ADM-PU-0003-VF-I1 PIC X(02).
- 005600 03 DATA-DT-6618-VF-I1 PIC X(06).
- 005700 03 ACT-CD-7350-VF-I1 PIC X(01).
- 005800 03 LINE-NO-3578-VF-I1 PIC X(04).
- 005900 03 ANML-GRZG-CD-3929-VF-I1 PIC X(02).
- 006000 03 MON-FORG-RQMT-3551-VF-I1 PIC X(04).
- 006100 03 ANML-HGT-CLS-CD-3548-VF-I1 PIC X(01).
- 006200 03 FILLER PIC X(36).
- 006300 01 FDR-VP.
- 006400 03 REC-TYPE-3529-VP-I1 PIC X(02).
- 006500 03 FMT-NO-3576-VP-I1 PIC X(01).
- 006600 03 FMT-CD-3579-VP-I1 PIC X(01).
- 006700 03 ADM-UNIT-0003-VP-I1 PIC X(08).
- 006800 03 DATA-DT-6618-VP-I1 PIC X(06).
- 006900 03 ACT-CD-7350-VP-I1 PIC X(01).
- 007000 03 LINE-NO-3578-VP-I1 PIC X(04).
- 007100 03 PLANT-CD-2646-VP-I1 PIC X(07).
- 007200 03 PHNO-ADJ-FCTR-3545-VP-I1 OCCURS 8 TIMES PIC X(04).
- 007300 03 FILLER PIC X(04).
- 007400 01 FDR-VU.
- 007500 03 REC-TYPE-3529-VU-I1 PIC X(02).
- 007600 03 FMT-NO-3576-VU-I1 PIC X(01).
- 007700 03 FMT-CD-3579-VU-I1 PIC X(01).
- 007800 03 ADM-UNIT-0003-VU-I1 PIC X(08).
- 007900 03 DATA-DT-6618-VU-I1 PIC X(06).
- 008000 03 ACT-CD-7350-VU-I1 PIC X(01).
- 008100 03 DUF-3917-VU-I1 PIC X(01).
- 008200 03 LINE-NO-3578-VU-I1 PIC X(04).
- 008300 03 PLANT-CD-2646-VU-I1 PIC X(07).
- 008400 03 AUF-3928-VU-I1 OCCURS 5 TIMES PIC X(03).
- 008500 03 ANML-GRZG-CD-3929-VU-I1 PIC X(02).
- 008600 03 PUF-3511-VU-I1 OCCURS 5 TIMES PIC X(02).
- 008700 03 FILLER PIC X(08).
- 008800 FD INPUT-FILE2 CODE-SET IS GBCD
- 008900 LABEL RECORDS ARE STANDARD
- 009000 DATA RECORD IS FDR-V7.
- 009100 01 FDR-V7.
- 009200 03 REC-TYPE-3529-V7-I1 PIC X(02).
- 009300 03 FMT-NO-3576-V7-I1 PIC X(01).
- 009400 03 FMT-CD-3579-V7-I1 PIC X(01).
- 009500 03 ADM-UNIT-0003-V7-I1 PIC X(08).
- 009600 03 DATA-DT-6618-V7-I1 PIC X(06).
- 009700 03 ACT-CD-7350-V7-I1 PIC X(01).
- 009800 03 LINE-NO-3578-V7-I1 PIC X(04).
- 009900 03 PLANT-CD-2646-V7-I1 OCCURS 9 TIMES PIC X(07).
- 010000 03 FILLER PIC X(04).
- 010100 FD PRINT-FILE CODE-SET IS GBCD
- 010200 LABEL RECORDS ARE STANDARD
- 010300 DATA RECORD IS PRT-REC.
- 010400 01 PRT-REC PIC X(132).
- 010500 SD SORT-FILE DATA RECORDS ARE S-KEY1, S-KEY2,
- 010600 S-KEY3, S-KEY4, S-KEY5.
- 010700 01 S-KEY1.
- 010800 03 S-KEY1A.
- 010900 05 REC-TYPE-3529-V6-S1 PIC X(02).
- 011000 05 FMT-NO-3576-V6-S1 PIC X(01).
- 011100 05 FMT-CD-3579-V6-S1 PIC X(01).
- 011200 05 ADM-UNIT-0003-V6-S1.
- 011300 10 ADM-ST-0003-V6-S1 PIC X(02).
- 011400 10 ADM-DI-0003-V6-S1 PIC X(02).
- 011500 10 ADM-RA-0003-V6-S1 PIC X(02).
- 011600 10 ADM-PU-0003-V6-S1 PIC X(02).
- 011700 05 PLANT-CD-2646-V6-S1 PIC X(07).
- 011800 05 PHNO-STG-CD-3712-V6-S1 PIC X(01).
- 011900 05 FILLER PIC X(04).
- 012000 03 DATA-DT-6618-V6-S1 PIC X(06).
- 012100 03 ACT-CD-7350-V6-S1 PIC X(01).
- 012200 03 LINE-NO-3578-V6-S1 PIC X(04).
- 012300 03 GRAMS-GRN-WGT-3941-V6-S1 PIC X(04).
- 012400 03 ADW-PCT-3546-V6-S1 PIC X(03).
- 012500 03 GRAMS-DRY-WGT-3942-V6-S1 PIC X(04).
- 012600 03 BA-DIMS-3533-V6-S1.
- 012700 05 BA-DIMS-MIN-3533-V6-S1 PIC X(04).
- 012800 05 BA-DIMS-MIN-RE-3533-V6-S1 REDEFINES
- 012900 BA-DIMS-MIN-3533-V6-S1 PIC 99V99.
- 013000 05 BA-DIMS-MAX-3533-V6-S1 PIC X(04).
- 013100 05 BA-DIMS-MAX-RE-3533-V6-S1 REDEFINES
- 013200 BA-DIMS-MAX-3533-V6-S1 PIC 99V99.
- 013300 03 CRN-DIMS-3534-V6-S1.
- 013400 05 CRN-DIMS-MIN-3534-V6-S1 PIC X(03).
- 013500 05 CRN-DIMS-MIN-RE-3534-V6-S1 REDEFINES
- 013600 CRN-DIMS-MIN-3534-V6-S1 PIC 99V9.
- 013700 05 CRN-DIMS-MAX-3534-V6-S1 PIC X(03).
- 013800 05 CRN-DIMS-MAX-RE-3534-V6-S1 REDEFINES
- 013900 CRN-DIMS-MAX-3534-V6-S1 PIC 99V9.
- 014000 03 HGT-AVG-3504-V6-S1 PIC X(04).
- 014100 03 HGT-AVG-RE-3504-V6-S1 REDEFINES HGT-AVG-3504-V6-S1
- 014200 PIC 999V9.
- 014300 03 AVG-LDR-LGT-7313-V6-S1 PIC X(03).
- 014400 03 AVG-LDR-LGT-RE-7313-V6-S1 REDEFINES
- 014500 AVG-LDR-LGT-7313-V6-S1 PIC 99V9.
- 014600 03 FILLER PIC X(35).
- 014700 01 S-KEY2.
- 014800 03 S-KEY1B.
- 014900 05 REC-TYPE-3529-V7-S1 PIC X(02).
- 015000 05 FMT-NO-3576-V7-S1 PIC X(01).
- 015100 05 FMT-CD-3579-V7-S1 PIC X(01).
- 015200 05 ADM-UNIT-0003-V7-S1.
- 015300 10 ADM-ST-0003-V7-S1 PIC X(02).
- 015400 10 ADM-DI-0003-V7-S1 PIC X(02).
- 015500 10 ADM-RA-0003-V7-S1 PIC X(02).
- 015600 10 ADM-PU-0003-V7-S1 PIC X(02).
- 015700 05 PLANT-CD1-2646-V7-S1 PIC X(07).
- 015800 05 FILLER PIC X(05).
- 015900 03 DATA-DT-6618-V7-S1 PIC X(06).
- 016000 03 ACT-CD-7350-V7-S1 PIC X(01).
- 016100 03 LINE-NO-3578-V7-S1 PIC X(04).
- 016200 03 PLANT-CD-2646-V7-S1 OCCURS 9 TIMES PIC X(07).
- 016300 03 FILLER PIC X(04).
- 016400 01 S-KEY3.
- 016500 03 S-KEY1C.
- 016600 05 REC-TYPE-3529-VF-S1 PIC X(02).
- 016700 05 FMT-NO-3576-VF-S1 PIC X(01).
- 016800 05 FMT-CD-3579-VF-S1 PIC X(01).
- 016900 05 ADM-UNIT-0003-VF-S1.
- 017000 10 ADM-ST-0003-VF-S1 PIC X(02).
- 017100 10 ADM-DI-0003-VF-S1 PIC X(02).
- 017200 05 ANML-GRZG-CD-3929-VF-S1 PIC X(02).
- 017300 05 FILLER PIC X(14).
- 017400 03 DATA-DT-6618-VF-S1 PIC X(06).
- 017500 03 ACT-CD-7350-VF-S1 PIC X(01).
- 017600 03 LINE-NO-3578-VF-S1 PIC X(04).
- 017700 03 MON-FORG-RQMT-3551-VF-S1 PIC X(04).
- 017800 03 ANML-HGT-CLS-CD-3548-VF-S1 PIC X(01).
- 017900 03 ADM-RA-0003-VF-S1 PIC X(02).
- 018000 03 ADM-PU-0003-VF-S1 PIC X(02).
- 018100 03 FILLER PIC X(58).
- 018200 01 S-KEY4.
- 018300 03 S-KEY1D.
- 018400 05 REC-TYPE-3529-VP-S1 PIC X(02).
- 018500 05 FMT-NO-3576-VP-S1 PIC X(01).
- 018600 05 FMT-CD-3579-VP-S1 PIC X(01).
- 018700 05 ADM-UNIT-0003-VP-S1.
- 018800 10 ADM-ST-0003-VP-S1 PIC X(02).
- 018900 10 ADM-DI-0003-VP-S1 PIC X(02).
- 019000 10 ADM-RA-0003-VP-S1 PIC X(02).
- 019100 10 ADM-PU-0003-VP-S1 PIC X(02).
- 019200 05 PLANT-CD-2646-VP-S1 PIC X(07).
- 019300 05 FILLER PIC X(05).
- 019400 03 DATA-DT-6618-VP-S1 PIC X(06).
- 019500 03 ACT-CD-7350-VP-S1 PIC X(01).
- 019600 03 LINE-NO-3578-VP-S1 PIC X(04).
- 019700 03 PHNO-ADJ-FCTR-3545-RE-VP-S1 PIC X(32).
- 019800 03 PHNO-ADJ-FCTR-3545-VP-S1 REDEFINES
- 019900 PHNO-ADJ-FCTR-3545-RE-VP-S1 OCCURS 8 TIMES PIC X(04).
- 020000 03 PHNO-ADJ-FCTR-RE-3545-VP-S1 REDEFINES
- 020100 PHNO-ADJ-FCTR-3545-RE-VP-S1 OCCURS 8 TIMES PIC 99V99.
- 020200 03 FILLER PIC X(35).
- 020300 01 S-KEY5.
- 020400 03 S-KEY1E.
- 020500 05 REC-TYPE-3529-VU-S1 PIC X(02).
- 020600 05 FMT-NO-3576-VU-S1 PIC X(01).
- 020700 05 FMT-CD-3579-VU-S1 PIC X(01).
- 020800 05 ADM-UNIT-0003-VU-S1.
- 020900 10 ADM-ST-0003-VU-S1 PIC X(02).
- 021000 10 ADM-DI-0003-VU-S1 PIC X(02).
- 021100 10 ADM-RA-0003-VU-S1 PIC X(02).
- 021200 10 ADM-PU-0003-VU-S1 PIC X(02).
- 021300 05 PLANT-CD-2646-VU-S1 PIC X(07).
- 021400 05 ANML-GRZG-CD-3929-VU-S1 PIC X(02).
- 021500 05 FILLER PIC X(03).
- 021600 03 DATA-DT-6618-VU-S1 PIC X(06).
- 021700 03 ACT-CD-7350-VU-S1 PIC X(01).
- 021800 03 DUF-3917-VU-S1 PIC X(01).
- 021900 03 LINE-NO-3578-VU-S1 PIC X(04).
- 022000 03 AUF-3928-VU-S1 OCCURS 5 TIMES PIC X(03).
- 022100 03 PUF-3511-VU-S1 OCCURS 5 TIMES PIC X(02).
- 022200 03 FILLER PIC X(41).
- 022300 WORKING-STORAGE SECTION.
- 022400 77 INPUT1-CNT PIC 9(07) VALUE 0.
- 022500 77 PAGE-CNT PIC 9(05) VALUE 0.
- 022600 77 V6-CNT PIC 9(07) VALUE 0.
- 022700 77 VF-CNT PIC 9(07) VALUE 0.
- 022800 77 VP-CNT PIC 9(07) VALUE 0.
- 022900 77 VU-CNT PIC 9(07) VALUE 0.
- 023000 77 INPUT2-CNT PIC 9(07) VALUE 0.
- 023100 77 LINE-CNT PIC 9(02) VALUE 66.
- 023200 01 HLD-REC-TYPE PIC X(02) VALUE SPACES.
- 023300 01 MONTH-TABLE.
- 023400 03 MO-TAB.
- 023500 05 FILLER PIC X(03) VALUE "JAN".
- 023600 05 FILLER PIC X(03) VALUE "FEB".
- 023700 05 FILLER PIC X(03) VALUE "MAR".
- 023800 05 FILLER PIC X(03) VALUE "APR".
- 023900 05 FILLER PIC X(03) VALUE "MAY".
- 024000 05 FILLER PIC X(03) VALUE "JUN".
- 024100 05 FILLER PIC X(03) VALUE "JUL".
- 024200 05 FILLER PIC X(03) VALUE "AUG".
- 024300 05 FILLER PIC X(03) VALUE "SEP".
- 024400 05 FILLER PIC X(03) VALUE "OCT".
- 024500 05 FILLER PIC X(03) VALUE "NOV".
- 024600 05 FILLER PIC X(03) VALUE "DEC".
- 024700 03 MON REDEFINES MO-TAB PIC X(03) OCCURS 12 TIMES.
- 024800 01 EOF-SWITCH PIC 9 VALUE ZERO.
- 024900 88 EOF VALUE 1.
- 025000 01 EOR-SWITCH PIC 9 VALUE ZERO.
- 025100 88 EOR VALUE 1.
- 025200 01 PARAMETER PIC X(04).
- 025300 01 HLD-DT.
- 025400 03 HOLD-DT.
- 025500 05 YR-DT PIC XX.
- 025600 05 MO-DT PIC 99.
- 025700 05 DY-DT PIC XX.
- 025800 03 INV-HLD.
- 025900 05 INV-NM PIC X(20).
- 026000 05 ST-DIST-CD.
- 026100 07 ST-CD-HLD PIC X(02).
- 026200 07 DI-CD-HLD PIC X(02).
- 026300 03 EXPL-HLD.
- 026400 05 DIST-NM-HLD PIC X(12).
- 026500 05 RA-NM-HLD PIC X(13).
- 026600 05 PU-NM-HLD PIC X(15).
- 026700 03 FUNC-HLD.
- 026800 05 ST-NM-HLD PIC X(10).
- 026900 05 FILLER PIC X(14).
- 027000 COPY DBSTATUS IN TPCOBOLIB.
- 027100 01 HDR-1.
- 027200 03 FILLER PIC X(08) VALUE
- 027300 " DATE: ".
- 027400 03 HDR-MO PIC X(03).
- 027500 03 FILLER PIC X(01) VALUE SPACE.
- 027600 03 HDR-DA PIC X(02).
- 027700 03 FILLER PIC X(04) VALUE ", 19".
- 027800 03 HDR-YR PIC X(02).
- 027900 03 FILLER PIC X(21) VALUE SPACES.
- 028000 03 FILLER PIC X(47) VALUE
- 028100 "US DEPT OF INTERIOR - BUREAU OF LAND MANAGEMENT".
- 028200 03 FILLER PIC X(29) VALUE SPACES.
- 028300 03 FILLER PIC X(07) VALUE
- 028400 "PAGE: ".
- 028500 03 HDR-PG PIC ZZ,ZZ9.
- 028600 03 FILLER PIC X(02) VALUE SPACES.
- 028700 01 HDR-2.
- 028800 03 FILLER PIC X(08) VALUE
- 028900 "STATE: ".
- 029000 03 HDR-ST-CD PIC X(02).
- 029100 03 FILLER PIC X(04) VALUE SPACES.
- 029200 03 HDR-ST-NM PIC X(10).
- 029300 03 FILLER PIC X(30) VALUE SPACES.
- 029400 03 FILLER PIC X(25) VALUE
- 029500 "ECOLOGICAL SITE INVENTORY".
- 029600 03 FILLER PIC X(35) VALUE SPACES.
- 029700 03 FILLER PIC X(18) VALUE
- 029800 "PROGRAM: ES115P ".
- 029900 01 HDR-3.
- 030000 03 FILLER PIC X(08) VALUE
- 030100 " DI: ".
- 030200 03 HDR-DIST-CD PIC X(02).
- 030300 03 FILLER PIC X(04) VALUE SPACES.
- 030400 03 HDR-DIST-NM PIC X(25).
- 030500 03 FILLER PIC X(79) VALUE SPACES.
- 030600 03 FILLER PIC X(14) VALUE
- 030700 "PCN: SV115P ".
- 030800 01 HDR-4.
- 030900 03 FILLER PIC X(08) VALUE
- 031000 " INV: ".
- 031100 03 HDR-INV-CD PIC X(04).
- 031200 03 FILLER PIC X(02) VALUE SPACES.
- 031300 03 HDR-INV-NM PIC X(25).
- 031400 03 FILLER PIC X(16) VALUE SPACES.
- 031500 03 HDR-REC-TYPE PIC X(02).
- 031600 03 FILLER PIC X(18) VALUE
- 031700 " VERIFICATION LIST".
- 031800 03 FILLER PIC X(57) VALUE SPACES.
- 031900 01 HDR-5-V6.
- 032000 03 FILLER PIC X(51) VALUE
- 032100 "(1-2) (3) (4) (5) ".
- 032200 03 FILLER PIC X(46) VALUE
- 032300 "(6) (7) (8) (9) (10) ".
- 032400 03 FILLER PIC X(34) VALUE
- 032500 "(11-12) (13) (14) ".
- 032600 01 HDR-6-V6.
- 032700 03 FILLER PIC X(51) VALUE
- 032800 " REC ADMINISTRATIVE UNIT DATE ACT LINE ".
- 032900 03 FILLER PIC X(39) VALUE
- 033000 "PLANT PHEN- GREEN % DRY DRY ".
- 033100 03 FILLER PIC X(42) VALUE
- 033200 "BASAL -DIMENSIONS- CROWN AVG LEADER ".
- 033300 01 HDR-7-V6.
- 033400 03 FILLER PIC X(45) VALUE
- 033500 "TYPE ST DI RA PU YYMMDD CD ".
- 033600 03 FILLER PIC X(52) VALUE
- 033700 "NO SYMBOL OLOGY WGT WGT WGT MIN ".
- 033800 03 FILLER PIC X(35) VALUE
- 033900 "MAX MIN MAX HGT LGTH ".
- 034000 01 HDR-8-V6.
- 034100 03 FILLER PIC X(51) VALUE
- 034200 " 1-4 5-6 7-8 9-10 11-12 13-18 19 20-23 ".
- 034300 03 FILLER PIC X(52) VALUE
- 034400 "24-30 31 32-35 36-38 39-42 43-46 47-50 ".
- 034500 03 FILLER PIC X(29) VALUE
- 034600 "51-53 54-56 57-60 61-63 ".
- 034700 01 HDR-9-V6.
- 034800 03 FILLER PIC X(44) VALUE
- 034900 "XXXX XX XX XX XX XXXXXX X ".
- 035000 03 FILLER PIC X(46) VALUE
- 035100 "XXXX XXXXXXX X XXXX XXX XXXX ".
- 035200 03 FILLER PIC X(42) VALUE
- 035300 "99.99 99.99 99.9 99.9 999.9 99.9 ".
- 035400 01 HDR-10-DET-V6.
- 035500 03 REC-TYPE-3529-V6-P1 PIC X(02).
- 035600 03 FMT-NO-3576-V6-P1 PIC X(01).
- 035700 03 FMT-CD-3579-V6-P1 PIC X(01).
- 035800 03 FILLER PIC X(04) VALUE SPACES.
- 035900 03 ADM-ST-0003-V6-P1 PIC X(02).
- 036000 03 FILLER PIC X(03) VALUE SPACES.
- 036100 03 ADM-DI-0003-V6-P1 PIC X(02).
- 036200 03 FILLER PIC X(03) VALUE SPACES.
- 036300 03 ADM-RA-0003-V6-P1 PIC X(02).
- 036400 03 FILLER PIC X(03) VALUE SPACES.
- 036500 03 ADM-PU-0003-V6-P1 PIC X(02).
- 036600 03 FILLER PIC X(04) VALUE SPACES.
- 036700 03 DATA-DT-6618-V6-P1 PIC X(06).
- 036800 03 FILLER PIC X(03) VALUE SPACES.
- 036900 03 ACT-CD-7350-V6-P1 PIC X(01).
- 037000 03 FILLER PIC X(05) VALUE SPACES.
- 037100 03 LINE-NO-3578-V6-P1 PIC X(04).
- 037200 03 FILLER PIC X(03) VALUE SPACES.
- 037300 03 PLANT-CD-2646-V6-P1 PIC X(07).
- 037400 03 FILLER PIC X(03) VALUE SPACES.
- 037500 03 PHNO-STG-CD-3712-V6-P1 PIC X(01).
- 037600 03 FILLER PIC X(05) VALUE SPACES.
- 037700 03 GRAMS-GRN-WGT-3941-V6-P1 PIC X(04).
- 037800 03 FILLER PIC X(04) VALUE SPACES.
- 037900 03 ADW-PCT-3546-V6-P1 PIC X(03).
- 038000 03 FILLER PIC X(05) VALUE SPACES.
- 038100 03 GRAMS-DRY-WGT-3942-V6-P1 PIC X(04).
- 038200 03 FILLER PIC X(03) VALUE SPACES.
- 038300 03 BA-DIMS-MIN-3533-V6-P1 PIC X(05).
- 038400 03 BA-DIMS-MIN-RE-3533-V6-P1 REDEFINES
- 038500 BA-DIMS-MIN-3533-V6-P1 PIC 99.99.
- 038600 03 FILLER PIC X(01) VALUE SPACE.
- 038700 03 BA-DIMS-MAX-3533-V6-P1 PIC X(05).
- 038800 03 BA-DIMS-MAX-RE-3533-V6-P1 REDEFINES
- 038900 BA-DIMS-MAX-3533-V6-P1 PIC 99.99.
- 039000 03 FILLER PIC X(02) VALUE SPACES.
- 039100 03 CRN-DIMS-MIN-3534-V6-P1 PIC X(04).
- 039200 03 CRN-DIMS-MIN-RE-3534-V6-P1 REDEFINES
- 039300 CRN-DIMS-MIN-3534-V6-P1 PIC 99.9.
- 039400 03 FILLER PIC X(02) VALUE SPACES.
- 039500 03 CRN-DIMS-MAX-3534-V6-P1 PIC X(04).
- 039600 03 CRN-DIMS-MAX-RE-3534-V6-P1 REDEFINES
- 039700 CRN-DIMS-MAX-3534-V6-P1 PIC 99.9.
- 039800 03 FILLER PIC X(04) VALUE SPACES.
- 039900 03 HGT-AVG-3504-V6-P1 PIC X(05).
- 040000 03 HGT-AVG-RE-3504-V6-P1 REDEFINES
- 040100 HGT-AVG-3504-V6-P1 PIC 999.9.
- 040200 03 FILLER PIC X(04) VALUE SPACES.
- 040300 03 AVG-LDR-LGT-7313-V6-P1 PIC X(04).
- 040400 03 AVG-LDR-LGT-RE-7313-V6-P1 REDEFINES
- 040500 AVG-LDR-LGT-7313-V6-P1 PIC 99.9.
- 040600 03 FILLER PIC X(02) VALUE SPACES.
- 040700 01 HDR-5-V7.
- 040800 03 FILLER PIC X(52) VALUE
- 040900 "(1-2) (3) (4) (5) ".
- 041000 03 FILLER PIC X(51) VALUE
- 041100 "(6) (7) PHENOLOGICAL EQUIVALENT SPECIES ".
- 041200 03 FILLER PIC X(29) VALUE
- 041300 "(UNSAMPLED) (7) ".
- 041400 01 HDR-6-V7.
- 041500 03 FILLER PIC X(51) VALUE
- 041600 " REC ADMINISTRATIVE UNIT DATE ACT LINE ".
- 041700 03 FILLER PIC X(54) VALUE
- 041800 "PLANT PLANT PLANT PLANT PLANT PLANT ".
- 041900 03 FILLER PIC X(27) VALUE
- 042000 "PLANT PLANT PLANT ".
- 042100 01 HDR-7-V7.
- 042200 03 FILLER PIC X(51) VALUE
- 042300 "TYPE ST DI RA PU YYMMDD CD NO ".
- 042400 03 FILLER PIC X(54) VALUE
- 042500 "SYMBOL SYMBOL SYMBOL SYMBOL SYMBOL SYMBOL ".
- 042600 03 FILLER PIC X(27) VALUE
- 042700 "SYMBOL SYMBOL SYMBOL ".
- 042800 01 HDR-8-V7.
- 042900 03 FILLER PIC X(51) VALUE
- 043000 " 1-4 5-6 7-8 9-10 11-12 13-18 19 20-23 ".
- 043100 03 FILLER PIC X(54) VALUE
- 043200 "24-30 31-37 38-44 45-51 52-58 59-65 ".
- 043300 03 FILLER PIC X(27) VALUE
- 043400 "66-72 73-79 80-86 ".
- 043500 01 HDR-9-V7.
- 043600 03 FILLER PIC X(44) VALUE
- 043700 "XXXX XX XX XX XX XXXXXX X ".
- 043800 03 FILLER PIC X(51) VALUE
- 043900 "XXXX XXXXXXX XXXXXXX XXXXXXX XXXXXXX XXXXXXX ".
- 044000 03 FILLER PIC X(37) VALUE
- 044100 "XXXXXXX XXXXXXX XXXXXXX XXXXXXX ".
- 044200 01 HDR-10-DET-V7.
- 044300 03 REC-TYPE-3529-V7-P1 PIC X(02).
- 044400 03 FMT-NO-3576-V7-P1 PIC X(01).
- 044500 03 FMT-CD-3579-V7-P1 PIC X(01).
- 044600 03 FILLER PIC X(04) VALUE SPACES.
- 044700 03 ADM-ST-0003-V7-P1 PIC X(02).
- 044800 03 FILLER PIC X(03) VALUE SPACES.
- 044900 03 ADM-DI-0003-V7-P1 PIC X(02).
- 045000 03 FILLER PIC X(03) VALUE SPACES.
- 045100 03 ADM-RA-0003-V7-P1 PIC X(02).
- 045200 03 FILLER PIC X(03) VALUE SPACES.
- 045300 03 ADM-PU-0003-V7-P1 PIC X(02).
- 045400 03 FILLER PIC X(04) VALUE SPACES.
- 045500 03 DATA-DT-6618-V7-P1 PIC X(06).
- 045600 03 FILLER PIC X(03) VALUE SPACES.
- 045700 03 ACT-CD-7350-V7-P1 PIC X(01).
- 045800 03 FILLER PIC X(05) VALUE SPACES.
- 045900 03 LINE-NO-3578-V7-P1 PIC X(04).
- 046000 03 FILLER PIC X(02) VALUE SPACES.
- 046100 03 PLANT-CD1-2646-V7-P1 PIC X(07).
- 046200 03 FILLER PIC X(02) VALUE SPACES.
- 046300 03 PLANT-CD2-2646-V7-P1 PIC X(07).
- 046400 03 FILLER PIC X(02) VALUE SPACES.
- 046500 03 PLANT-CD3-2646-V7-P1 PIC X(07).
- 046600 03 FILLER PIC X(02) VALUE SPACES.
- 046700 03 PLANT-CD4-2646-V7-P1 PIC X(07).
- 046800 03 FILLER PIC X(02) VALUE SPACES.
- 046900 03 PLANT-CD5-2646-V7-P1 PIC X(07).
- 047000 03 FILLER PIC X(02) VALUE SPACES.
- 047100 03 PLANT-CD6-2646-V7-P1 PIC X(07).
- 047200 03 FILLER PIC X(02) VALUE SPACES.
- 047300 03 PLANT-CD7-2646-V7-P1 PIC X(07).
- 047400 03 FILLER PIC X(02) VALUE SPACES.
- 047500 03 PLANT-CD8-2646-V7-P1 PIC X(07).
- 047600 03 FILLER PIC X(02) VALUE SPACES.
- 047700 03 PLANT-CD9-2646-V7-P1 PIC X(07).
- 047800 03 FILLER PIC X(03) VALUE SPACES.
- 047900 01 HDR-5-VF.
- 048000 03 FILLER PIC X(40) VALUE
- 048100 "(1-2 (3) (4) (5)".
- 048200 03 FILLER PIC X(92) VALUE SPACES.
- 048300 01 HDR-6-VF.
- 048400 03 FILLER PIC X(49) VALUE
- 048500 " REC ADMINISTRATIVE UNIT DATE ACT LINE".
- 048600 03 FILLER PIC X(12) VALUE SPACES.
- 048700 03 FILLER PIC X(51) VALUE
- 048800 "ANIMAL SPECIES MO FOR HEIGHT CLASS ".
- 048900 03 FILLER PIC X(21) VALUE
- 049000 "AVAILABLE TO ANIMAL ".
- 049100 01 HDR-7-VF.
- 049200 03 FILLER PIC X(47) VALUE
- 049300 "TYPE ST DI YYMMDD CD NO".
- 049400 03 FILLER PIC X(45) VALUE
- 049500 " NAME CD REQ".
- 049600 03 FILLER PIC X(40) VALUE
- 049700 " 0'-3' 3'-4.5' 4.5'-7' 7' PLUS ".
- 049800 01 HDR-8-VF.
- 049900 03 FILLER PIC X(49) VALUE
- 050000 " 1-4 5-6 7-8 13-18 19 20-23".
- 050100 03 FILLER PIC X(32) VALUE SPACES.
- 050200 03 FILLER PIC X(51) VALUE
- 050300 "24-25 26-29 X X X X ".
- 050400 01 HDR-9-VF.
- 050500 03 FILLER PIC X(53) VALUE
- 050600 "XXXX XX XX XXXXXX X XXXX ".
- 050700 03 FILLER PIC X(46) VALUE
- 050800 "XXXXXXXXXXXXXXXXXXXXXXXXX XX XXXX ".
- 050900 03 FILLER PIC X(33) VALUE
- 051000 "1 2 3 4 ".
- 051100 01 HDR-10-DET-VF.
- 051200 03 REC-TYPE-3529-VF-P1 PIC X(02).
- 051300 03 FMT-NO-3576-VF-P1 PIC X(01).
- 051400 03 FMT-CD-3579-VF-P1 PIC X(01).
- 051500 03 FILLER PIC X(06) VALUE SPACES.
- 051600 03 ADM-ST-0003-VF-P1 PIC X(02).
- 051700 03 FILLER PIC X(07) VALUE SPACES.
- 051800 03 ADM-DI-0003-VF-P1 PIC X(02).
- 051900 03 FILLER PIC X(08) VALUE SPACES.
- 052000 03 DATA-DT-6618-VF-P1 PIC X(06).
- 052100 03 FILLER PIC X(03) VALUE SPACES.
- 052200 03 ACT-CD-7350-VF-P1 PIC X(01).
- 052300 03 FILLER PIC X(05) VALUE SPACES.
- 052400 03 LINE-NO-3578-VF-P1 PIC X(04).
- 052500 03 FILLER PIC X(05) VALUE SPACES.
- 052600 03 ANML-GRZG-NAME-VF-P1 PIC X(25).
- 052700 03 FILLER PIC X(04) VALUE SPACES.
- 052800 03 ANML-GRZG-CD-3929-VF-P1 PIC X(02).
- 052900 03 FILLER PIC X(04) VALUE SPACES.
- 053000 03 MON-FORG-RQMT-3551-VF-P1 PIC X(04).
- 053100 03 FILLER PIC X(07) VALUE SPACES.
- 053200 03 ANML-HGT-0-3-3548-VF-P1 PIC X(01).
- 053300 03 FILLER PIC X(08) VALUE SPACES.
- 053400 03 ANML-HGT-3-4-3548-VF-P1 PIC X(01).
- 053500 03 FILLER PIC X(09) VALUE SPACES.
- 053600 03 ANML-HGT-4-7-3548-VF-P1 PIC X(01).
- 053700 03 FILLER PIC X(08) VALUE SPACES.
- 053800 03 ANML-HGT-7-OVR-3548-VF-P1 PIC X(01).
- 053900 03 FILLER PIC X(04) VALUE SPACES.
- 054000 01 HDR-5-VP.
- 054100 03 FILLER PIC X(40) VALUE
- 054200 "(1-2) (3) (4) (5)".
- 054300 03 FILLER PIC X(49) VALUE
- 054400 " (6) (7) PERCENT OF MAXIMUM ".
- 054500 03 FILLER PIC X(43) VALUE
- 054600 "PRODUCTION BY PHENOLOGY STATE (7) ".
- 054700 01 HDR-6-VP.
- 054800 03 FILLER PIC X(54) VALUE
- 054900 " REC ADMINISTRATIVE UNIT DATE ACT LINE ".
- 055000 03 FILLER PIC X(49) VALUE
- 055100 "PLANT BEG VEG BOOT PEAK SEED".
- 055200 03 FILLER PIC X(25) VALUE SPACES.
- 055300 03 FILLER PIC X(4) VALUE
- 055400 "RE- ".
- 055500 01 HDR-7-VP.
- 055600 03 FILLER PIC X(47) VALUE
- 055700 "TYPE ST DI RA PU YYMMDD CD NO".
- 055800 03 FILLER PIC X(48) VALUE
- 055900 " SYMBOL GROWTH STAGE STAGE FLURG".
- 056000 03 FILLER PIC X(37) VALUE
- 056100 " RIPE MAT DORM GROWTH".
- 056200 01 HDR-8-VP.
- 056300 03 FILLER PIC X(53) VALUE
- 056400 "1-4 5-6 7-8 9-10 11-12 13-18 19 20-23 ".
- 056500 03 FILLER PIC X(51) VALUE
- 056600 "24-30 31-34 35-38 39-42 43-46 47-50".
- 056700 03 FILLER PIC X(28) VALUE
- 056800 " 51-54 55-58 59-62 ".
- 056900 01 HDR-9-VP.
- 057000 03 FILLER PIC X(52) VALUE
- 057100 "XXXX XX XX XX XX XXXXXX X XXXX ".
- 057200 03 FILLER PIC X(52) VALUE
- 057300 "XXXXXXX 99.99 99.99 99.99 99.99 99.99".
- 057400 03 FILLER PIC X(28) VALUE
- 057500 " 99.99 99.99 99.99 ".
- 057600 01 HDR-10-DET-VP.
- 057700 03 REC-TYPE-3529-VP-P1 PIC X(02).
- 057800 03 FMT-NO-3576-VP-P1 PIC X(01).
- 057900 03 FMT-CD-3579-VP-P1 PIC X(01).
- 058000 03 FILLER PIC X(04) VALUE SPACES.
- 058100 03 ADM-ST-0003-VP-P1 PIC X(02).
- 058200 03 FILLER PIC X(03) VALUE SPACES.
- 058300 03 ADM-DI-0003-VP-P1 PIC X(02).
- 058400 03 FILLER PIC X(03) VALUE SPACES.
- 058500 03 ADM-RA-0003-VP-P1 PIC X(02).
- 058600 03 FILLER PIC X(03) VALUE SPACES.
- 058700 03 ADM-PU-0003-VP-P1 PIC X(02).
- 058800 03 FILLER PIC X(04) VALUE SPACES.
- 058900 03 DATA-DT-6618-VP-P1 PIC X(06).
- 059000 03 FILLER PIC X(03) VALUE SPACES.
- 059100 03 ACT-CD-7350-VP-P1 PIC X(01).
- 059200 03 FILLER PIC X(05) VALUE SPACES.
- 059300 03 LINE-NO-3578-VP-P1 PIC X(04).
- 059400 03 FILLER PIC X(04) VALUE SPACES.
- 059500 03 PLANT-CD-2646-VP-P1 PIC X(07).
- 059600 03 FILLER PIC X(04) VALUE SPACES.
- 059700 03 PHNO-ADJ-FCTR1-3545-VP-P1 PIC 99.99.
- 059800 03 PHNO-ADJ-FCTR1-RE-3545-VP-P1 REDEFINES
- 059900 PHNO-ADJ-FCTR1-3545-VP-P1 PIC X(05).
- 060000 03 FILLER PIC X(04) VALUE SPACES.
- 060100 03 PHNO-ADJ-FCTR2-3545-VP-P1 PIC 99.99.
- 060200 03 PHNO-ADJ-FCTR2-RE-3545-VP-P1 REDEFINES
- 060300 PHNO-ADJ-FCTR2-3545-VP-P1 PIC X(05).
- 060400 03 FILLER PIC X(04) VALUE SPACES.
- 060500 03 PHNO-ADJ-FCTR3-3545-VP-P1 PIC 99.99.
- 060600 03 PHNO-ADJ-FCTR3-RE-3545-VP-P1 REDEFINES
- 060700 PHNO-ADJ-FCTR3-3545-VP-P1 PIC X(05).
- 060800 03 FILLER PIC X(04) VALUE SPACES.
- 060900 03 PHNO-ADJ-FCTR4-3545-VP-P1 PIC 99.99.
- 061000 03 PHNO-ADJ-FCTR4-RE-3545-VP-P1 REDEFINES
- 061100 PHNO-ADJ-FCTR4-3545-VP-P1 PIC X(05).
- 061200 03 FILLER PIC X(04) VALUE SPACES.
- 061300 03 PHNO-ADJ-FCTR5-3545-VP-P1 PIC 99.99.
- 061400 03 PHNO-ADJ-FCTR5-RE-3545-VP-P1 REDEFINES
- 061500 PHNO-ADJ-FCTR5-3545-VP-P1 PIC X(05).
- 061600 03 FILLER PIC X(04) VALUE SPACES.
- 061700 03 PHNO-ADJ-FCTR6-3545-VP-P1 PIC 99.99.
- 061800 03 PHNO-ADJ-FCTR6-RE-3545-VP-P1 REDEFINES
- 061900 PHNO-ADJ-FCTR6-3545-VP-P1 PIC X(05).
- 062000 03 FILLER PIC X(04) VALUE SPACES.
- 062100 03 PHNO-ADJ-FCTR7-3545-VP-P1 PIC 99.99.
- 062200 03 PHNO-ADJ-FCTR7-RE-3545-VP-P1 REDEFINES
- 062300 PHNO-ADJ-FCTR7-3545-VP-P1 PIC X(05).
- 062400 03 FILLER PIC X(04) VALUE SPACES.
- 062500 03 PHNO-ADJ-FCTR8-3545-VP-P1 PIC 99.99.
- 062600 03 PHNO-ADJ-FCTR8-RE-3545-VP-P1 REDEFINES
- 062700 PHNO-ADJ-FCTR8-3545-VP-P1 PIC X(05).
- 062800 03 FILLER PIC X(01) VALUE SPACES.
- 062900 01 HDR-5-VU.
- 063000 03 FILLER PIC X(5) VALUE
- 063100 "(1-2)".
- 063200 03 FILLER PIC X(26) VALUE SPACES.
- 063300 03 FILLER PIC X(18) VALUE
- 063400 "(4) (5) (9-10)".
- 063500 03 FILLER PIC X(12) VALUE SPACES.
- 063600 03 FILLER PIC X(39) VALUE
- 063700 "(6) (7) ALLOWABLE USE FACTOR (7) (8)".
- 063800 03 FILLER PIC X(5) VALUE SPACES.
- 063900 03 FILLER PIC X(27) VALUE
- 064000 "PROPER USE FACTOR OR ".
- 064100 01 HDR-6-VU.
- 064200 03 FILLER PIC X(51) VALUE
- 064300 " REC ADMINISTRATIVE UNIT DATE ACT P OR ".
- 064400 03 FILLER PIC X(54) VALUE
- 064500 "LINE PLANT (PERCENT OF PLANT UTILIZED) ANIM ".
- 064600 03 FILLER PIC X(27) VALUE
- 064700 "DIETARY PREFERENCE VALUE ".
- 064800 01 HDR-7-VU.
- 064900 03 FILLER PIC X(52) VALUE
- 065000 "TYPE ST DI RA PU YYMMDD CD D ".
- 065100 03 FILLER PIC X(51) VALUE
- 065200 "NO SYMBOL SPRING SUM FALL WINT YR SP ".
- 065300 03 FILLER PIC X(29) VALUE
- 065400 "SPRING SUM FALL WINT YR ".
- 065500 01 HDR-8-VU.
- 065600 03 FILLER PIC X(51) VALUE
- 065700 " 1-4 5-6 7-8 9-10 11-12 13-18 19 20 ".
- 065800 03 FILLER PIC X(52) VALUE
- 065900 "21-24 25-31 32-34 35-37 38-40 41-43 44-46 47-48 ".
- 066000 03 FILLER PIC X(30) VALUE
- 066100 " 49-50 51-52 53-54 55-56 57-58".
- 066200 01 HDR-9-VU.
- 066300 03 FILLER PIC X(51) VALUE
- 066400 "XXXX XX XX XX XX XXXXXX X X ".
- 066500 03 FILLER PIC X(47) VALUE
- 066600 "XXXX XXXXXXX XXX XXX XXX XXX XXX ".
- 066700 03 FILLER PIC X(34) VALUE
- 066800 "XX XX XX XX XX XX ".
- 066900 01 HDR-10-DET-VU.
- 067000 03 REC-TYPE-3529-VU-P1 PIC X(02).
- 067100 03 FMT-NO-3576-VU-P1 PIC X(01).
- 067200 03 FMT-CD-3579-VU-P1 PIC X(01).
- 067300 03 FILLER PIC X(04) VALUE SPACES.
- 067400 03 ADM-ST-0003-VU-P1 PIC X(02).
- 067500 03 FILLER PIC X(03) VALUE SPACES.
- 067600 03 ADM-DI-0003-VU-P1 PIC X(02).
- 067700 03 FILLER PIC X(03) VALUE SPACES.
- 067800 03 ADM-RA-0003-VU-P1 PIC X(02).
- 067900 03 FILLER PIC X(03) VALUE SPACES.
- 068000 03 ADM-PU-0003-VU-P1 PIC X(02).
- 068100 03 FILLER PIC X(04) VALUE SPACES.
- 068200 03 DATA-DT-6618-VU-P1 PIC X(06).
- 068300 03 FILLER PIC X(04) VALUE SPACES.
- 068400 03 ACT-CD-7350-VU-P1 PIC X(01).
- 068500 03 FILLER PIC X(05) VALUE SPACES.
- 068600 03 DUF-3917-VU-P1 PIC X(01).
- 068700 03 FILLER PIC X(05) VALUE SPACES.
- 068800 03 LINE-NO-3578-VU-P1 PIC X(04).
- 068900 03 FILLER PIC X(03) VALUE SPACES.
- 069000 03 PLANT-CD-2646-VU-P1 PIC X(07).
- 069100 03 FILLER PIC X(03) VALUE SPACES.
- 069200 03 AUF1-3928-VU-P1 PIC X(03).
- 069300 03 FILLER PIC X(03) VALUE SPACES.
- 069400 03 AUF2-3928-VU-P1 PIC X(03).
- 069500 03 FILLER PIC X(03) VALUE SPACES.
- 069600 03 AUF3-3928-VU-P1 PIC X(03).
- 069700 03 FILLER PIC X(03) VALUE SPACES.
- 069800 03 AUF4-3928-VU-P1 PIC X(03).
- 069900 03 FILLER PIC X(03) VALUE SPACES.
- 070000 03 AUF5-3928-VU-P1 PIC X(03).
- 070100 03 FILLER PIC X(03) VALUE SPACES.
- 070200 03 ANML-GRZG-CD-3929-VU-P1 PIC X(02).
- 070300 03 FILLER PIC X(04) VALUE SPACES.
- 070400 03 PUF1-3511-VU-P1 PIC X(02).
- 070500 03 FILLER PIC X(04) VALUE SPACES.
- 070600 03 PUF2-3511-VU-P1 PIC X(02).
- 070700 03 FILLER PIC X(04) VALUE SPACES.
- 070800 03 PUF3-3511-VU-P1 PIC X(02).
- 070900 03 FILLER PIC X(04) VALUE SPACES.
- 071000 03 PUF4-3511-VU-P1 PIC X(02).
- 071100 03 FILLER PIC X(04) VALUE SPACES.
- 071200 03 PUF5-3511-VU-P1 PIC X(02).
- 071300 03 FILLER PIC X(02) VALUE SPACES.
- 071400 PROCEDURE DIVISION.
- 071500 START-SORT SECTION.
- 071600 100-SORT.
- 071700 SORT SORT-FILE ON ASCENDING S-KEY1A
- 071800 INPUT PROCEDURE PRE-SORT
- 071900 OUTPUT PROCEDURE POST-SORT.
- 072000 200-END-SECTION.
- 072100 FINISH DIC-DE.
- 072200 DISPLAY "V6-CNT" V6-CNT.
- 072300 DISPLAY "V7-CNT" INPUT2-CNT.
- 072400 DISPLAY "VF-CNT" VF-CNT.
- 072500 DISPLAY "VP-CNT" VP-CNT.
- 072600 DISPLAY "VU-CNT" VU-CNT.
- 072700 CLOSE PRINT-FILE.
- 072800 STOP RUN.
- 072900 PRE-SORT SECTION.
- 073000 300-HSKPNG.
- 073100 OPEN INPUT INPUT-FILE1.
- 073200 MOVE SPACES TO S-KEY1 S-KEY2 S-KEY3 S-KEY4 S-KEY5.
- 073300 400-MAIN.
- 073400 PERFORM 500-RD-FILE1 THRU 600-EXIT-RD-FL1 UNTIL EOF.
- 073500 MOVE 0 TO EOF-SWITCH.
- 073600 CLOSE INPUT-FILE1.
- 073700 OPEN INPUT INPUT-FILE2.
- 073800 PERFORM 2000-RD-FILE2 THRU 3000-EXIT-RD-FL2 UNTIL EOF.
- 073900 CLOSE INPUT-FILE2.
- 074000 GO TO 3000-EXIT-RD-FL2.
- 074100 500-RD-FILE1.
- 074200 READ INPUT-FILE1 AT END MOVE 1 TO EOF-SWITCH.
- 074300 IF (EOF-SWITCH = 1) GO TO 600-EXIT-RD-FL1.
- 074400 ADD 1 TO INPUT1-CNT.
- 074500 IF REC-TYPE-3529-V6-I1 = "V6"
- 074600 PERFORM 700-MV-V6-TO-SRT THRU 750-EXIT-V6
- 074700 GO TO 600-EXIT-RD-FL1.
- 074800 IF REC-TYPE-3529-VF-I1 = "VF"
- 074900 PERFORM 800-MV-VF-TO-SRT THRU 850-EXIT-VF
- 075000 GO TO 600-EXIT-RD-FL1.
- 075100 IF REC-TYPE-3529-VP-I1 = "VP"
- 075200 PERFORM 900-MV-VP-TO-SRT THRU 950-EXIT-VP
- 075300 GO TO 600-EXIT-RD-FL1.
- 075400 IF REC-TYPE-3529-VU-I1 = "VU"
- 075500 PERFORM 1000-MV-VU-TO-SRT THRU 1050-EXIT-VU
- 075600 GO TO 600-EXIT-RD-FL1.
- 075700 600-EXIT-RD-FL1.
- 075800 EXIT.
- 075900 700-MV-V6-TO-SRT.
- 076000 ADD 1 TO V6-CNT.
- 076100 MOVE REC-TYPE-3529-V6-I1 TO REC-TYPE-3529-V6-S1.
- 076200 MOVE FMT-NO-3576-V6-I1 TO FMT-NO-3576-V6-S1.
- 076300 MOVE FMT-CD-3579-V6-I1 TO FMT-CD-3579-V6-S1.
- 076400 MOVE ADM-UNIT-0003-V6-I1 TO ADM-UNIT-0003-V6-S1.
- 076500 MOVE DATA-DT-6618-V6-I1 TO DATA-DT-6618-V6-S1.
- 076600 MOVE ACT-CD-7350-V6-I1 TO ACT-CD-7350-V6-S1.
- 076700 MOVE LINE-NO-3578-V6-I1 TO LINE-NO-3578-V6-S1.
- 076800 MOVE PLANT-CD-2646-V6-I1 TO PLANT-CD-2646-V6-S1.
- 076900 MOVE PHNO-STG-CD-3712-V6-I1 TO PHNO-STG-CD-3712-V6-S1.
- 077000 MOVE GRAMS-GRN-WGT-3941-V6-I1 TO GRAMS-GRN-WGT-3941-V6-S1.
- 077100 MOVE ADW-PCT-3546-V6-I1 TO ADW-PCT-3546-V6-S1.
- 077200 MOVE GRAMS-DRY-WGT-3942-V6-I1 TO GRAMS-DRY-WGT-3942-V6-S1.
- 077300 MOVE BASAL-DIMS-3533-V6-I1 TO BA-DIMS-3533-V6-S1.
- 077400 MOVE CROWN-DIMS-3534-V6-I1 TO CRN-DIMS-3534-V6-S1.
- 077500 MOVE HGT-AVG-3504-V6-I1 TO HGT-AVG-3504-V6-S1.
- 077600 MOVE AVG-LDR-LGT-7313-V6-I1 TO AVG-LDR-LGT-7313-V6-S1.
- 077700 RELEASE S-KEY1.
- 077800 750-EXIT-V6.
- 077900 EXIT.
- 078000 800-MV-VF-TO-SRT.
- 078100 ADD 1 TO VF-CNT.
- 078200 MOVE REC-TYPE-3529-VF-I1 TO REC-TYPE-3529-VF-S1.
- 078300 MOVE FMT-NO-3576-VF-I1 TO FMT-NO-3576-VF-S1.
- 078400 MOVE FMT-CD-3579-VF-I1 TO FMT-CD-3579-VF-S1.
- 078500 MOVE ADM-ST-0003-VF-I1 TO ADM-ST-0003-VF-S1.
- 078600 MOVE ADM-DI-0003-VF-I1 TO ADM-DI-0003-VF-S1.
- 078700 MOVE DATA-DT-6618-VF-I1 TO DATA-DT-6618-VF-S1.
- 078800 MOVE ACT-CD-7350-VF-I1 TO ACT-CD-7350-VF-S1.
- 078900 MOVE LINE-NO-3578-VF-I1 TO LINE-NO-3578-VF-S1.
- 079000 MOVE ANML-GRZG-CD-3929-VF-I1 TO ANML-GRZG-CD-3929-VF-S1.
- 079100 MOVE MON-FORG-RQMT-3551-VF-I1 TO MON-FORG-RQMT-3551-VF-S1.
- 079200 MOVE ANML-HGT-CLS-CD-3548-VF-I1 TO ANML-HGT-CLS-CD-3548-VF-S1
- 079300 RELEASE S-KEY3.
- 079400 850-EXIT-VF.
- 079500 EXIT.
- 079600 900-MV-VP-TO-SRT.
- 079700 ADD 1 TO VP-CNT.
- 079800 MOVE REC-TYPE-3529-VP-I1 TO REC-TYPE-3529-VP-S1.
- 079900 MOVE FMT-NO-3576-VP-I1 TO FMT-NO-3576-VP-S1.
- 080000 MOVE FMT-CD-3579-VP-I1 TO FMT-CD-3579-VP-S1.
- 080100 MOVE ADM-UNIT-0003-VP-I1 TO ADM-UNIT-0003-VP-S1.
- 080200 MOVE DATA-DT-6618-VP-I1 TO DATA-DT-6618-VP-S1.
- 080300 MOVE ACT-CD-7350-VP-I1 TO ACT-CD-7350-VP-S1.
- 080400 MOVE LINE-NO-3578-VP-I1 TO LINE-NO-3578-VP-S1.
- 080500 MOVE PLANT-CD-2646-VP-I1 TO PLANT-CD-2646-VP-S1.
- 080600 MOVE PHNO-ADJ-FCTR-3545-VP-I1 (1) TO
- 080700 PHNO-ADJ-FCTR-3545-VP-S1 (1).
- 080800 MOVE PHNO-ADJ-FCTR-3545-VP-I1 (2) TO
- 080900 PHNO-ADJ-FCTR-3545-VP-S1 (2).
- 081000 MOVE PHNO-ADJ-FCTR-3545-VP-I1 (3) TO
- 081100 PHNO-ADJ-FCTR-3545-VP-S1 (3).
- 081200 MOVE PHNO-ADJ-FCTR-3545-VP-I1 (4) TO
- 081300 PHNO-ADJ-FCTR-3545-VP-S1 (4).
- 081400 MOVE PHNO-ADJ-FCTR-3545-VP-I1 (5) TO
- 081500 PHNO-ADJ-FCTR-3545-VP-S1 (5).
- 081600 MOVE PHNO-ADJ-FCTR-3545-VP-I1 (6) TO
- 081700 PHNO-ADJ-FCTR-3545-VP-S1 (6).
- 081800 MOVE PHNO-ADJ-FCTR-3545-VP-I1 (7) TO
- 081900 PHNO-ADJ-FCTR-3545-VP-S1 (7).
- 082000 MOVE PHNO-ADJ-FCTR-3545-VP-I1 (8) TO
- 082100 PHNO-ADJ-FCTR-3545-VP-S1 (8).
- 082200 RELEASE S-KEY4.
- 082300 950-EXIT-VP.
- 082400 EXIT.
- 082500 1000-MV-VU-TO-SRT.
- 082600 ADD 1 TO VU-CNT.
- 082700 MOVE REC-TYPE-3529-VU-I1 TO REC-TYPE-3529-VU-S1.
- 082800 MOVE FMT-NO-3576-VU-I1 TO FMT-NO-3576-VU-S1.
- 082900 MOVE FMT-CD-3579-VU-I1 TO FMT-CD-3579-VU-S1.
- 083000 MOVE ADM-UNIT-0003-VU-I1 TO ADM-UNIT-0003-VU-S1.
- 083100 MOVE DATA-DT-6618-VU-I1 TO DATA-DT-6618-VU-S1.
- 083200 MOVE ACT-CD-7350-VU-I1 TO ACT-CD-7350-VU-S1.
- 083300 MOVE DUF-3917-VU-I1 TO DUF-3917-VU-S1.
- 083400 MOVE LINE-NO-3578-VU-I1 TO LINE-NO-3578-VU-S1.
- 083500 MOVE PLANT-CD-2646-VU-I1 TO PLANT-CD-2646-VU-S1.
- 083600 MOVE AUF-3928-VU-I1 (1) TO AUF-3928-VU-S1 (1).
- 083700 MOVE AUF-3928-VU-I1 (2) TO AUF-3928-VU-S1 (2).
- 083800 MOVE AUF-3928-VU-I1 (3) TO AUF-3928-VU-S1 (3).
- 083900 MOVE AUF-3928-VU-I1 (4) TO AUF-3928-VU-S1 (4).
- 084000 MOVE AUF-3928-VU-I1 (5) TO AUF-3928-VU-S1 (5).
- 084100 MOVE ANML-GRZG-CD-3929-VU-I1 TO ANML-GRZG-CD-3929-VU-S1.
- 084200 MOVE PUF-3511-VU-I1 (1) TO PUF-3511-VU-S1 (1).
- 084300 MOVE PUF-3511-VU-I1 (2) TO PUF-3511-VU-S1 (2).
- 084400 MOVE PUF-3511-VU-I1 (3) TO PUF-3511-VU-S1 (3).
- 084500 MOVE PUF-3511-VU-I1 (4) TO PUF-3511-VU-S1 (4).
- 084600 MOVE PUF-3511-VU-I1 (5) TO PUF-3511-VU-S1 (5).
- 084700 RELEASE S-KEY5.
- 084800 1050-EXIT-VU.
- 084900 EXIT.
- 085000 2000-RD-FILE2.
- 085100 READ INPUT-FILE2 AT END MOVE 1 TO EOF-SWITCH.
- 085200 IF (EOF-SWITCH = 1) GO TO 3000-EXIT-RD-FL2.
- 085300 ADD 1 TO INPUT2-CNT.
- 085400 MOVE REC-TYPE-3529-V7-I1 TO REC-TYPE-3529-V7-S1.
- 085500 MOVE FMT-NO-3576-V7-I1 TO FMT-NO-3576-V7-S1.
- 085600 MOVE FMT-CD-3579-V7-I1 TO FMT-CD-3579-V7-S1.
- 085700 MOVE ADM-UNIT-0003-V7-I1 TO ADM-UNIT-0003-V7-S1.
- 085800 MOVE DATA-DT-6618-V7-I1 TO DATA-DT-6618-V7-S1.
- 085900 MOVE ACT-CD-7350-V7-I1 TO ACT-CD-7350-V7-S1.
- 086000 MOVE LINE-NO-3578-V7-I1 TO LINE-NO-3578-V7-S1.
- 086100 MOVE PLANT-CD-2646-V7-I1 (1) TO PLANT-CD1-2646-V7-S1.
- 086200 MOVE PLANT-CD-2646-V7-I1 (1) TO PLANT-CD-2646-V7-S1 (1).
- 086300 MOVE PLANT-CD-2646-V7-I1 (2) TO PLANT-CD-2646-V7-S1 (2).
- 086400 MOVE PLANT-CD-2646-V7-I1 (3) TO PLANT-CD-2646-V7-S1 (3).
- 086500 MOVE PLANT-CD-2646-V7-I1 (4) TO PLANT-CD-2646-V7-S1 (4).
- 086600 MOVE PLANT-CD-2646-V7-I1 (5) TO PLANT-CD-2646-V7-S1 (5).
- 086700 MOVE PLANT-CD-2646-V7-I1 (6) TO PLANT-CD-2646-V7-S1 (6).
- 086800 MOVE PLANT-CD-2646-V7-I1 (7) TO PLANT-CD-2646-V7-S1 (7).
- 086900 MOVE PLANT-CD-2646-V7-I1 (8) TO PLANT-CD-2646-V7-S1 (8).
- 087000 MOVE PLANT-CD-2646-V7-I1 (9) TO PLANT-CD-2646-V7-S1 (9).
- 087100 RELEASE S-KEY2.
- 087200 3000-EXIT-RD-FL2.
- 087300 EXIT.
- 087400 POST-SORT SECTION.
- 087500 3050-RET-HSKPNG.
- 087600 OPEN OUTPUT PRINT-FILE.
- 087700 ACCEPT PARAMETER.
- 087800 ACCEPT HOLD-DT FROM DATE.
- 087900 MOVE YR-DT TO HDR-YR.
- 088000 MOVE MON(MO-DT) TO HDR-MO.
- 088100 MOVE DY-DT TO HDR-DA.
- 088200 READY DIC-DE.
- 088300 PERFORM 4000-VALIDATE-INV THRU 4050-EXIT-STDI.
- 088400 RETURN SORT-FILE AT END MOVE 1 TO EOR-SWITCH.
- 088500 MOVE REC-TYPE-3529-V6-S1 TO HLD-REC-TYPE.
- 088600 PERFORM 4100-CHK-LINE-CNT THRU 4150-EXIT-LINE-OVR50.
- 088700 3070-MAIN-DRIVER.
- 088800 PERFORM 4300-DET-REC-LINE THRU 4350-EXIT-RET UNTIL EOR.
- 088900 IF (EOR-SWITCH = 1) GO TO 4830-DUMMY.
- 089000 4000-VALIDATE-INV.
- 089100 MOVE PARAMETER TO DE-CD-8822-DEC HDR-INV-CD.
- 089200 MOVE 3940 TO DE-NO-8801-DEC.
- 089300 FIND ANY CODE-DEC.
- 089400 MOVE DB-STATUS TO DB-STAT.
- 089500 IF NOT OK
- 089600 MOVE "UNKNOWN" TO HDR-ST-NM HDR-DIST-NM HDR-INV-NM
- 089700 GO TO 4050-EXIT-STDI.
- 089800 GET CODE-DEC.
- 089900 MOVE DB-STATUS TO DB-STAT.
- 090000 IF NOT OK
- 090100 DISPLAY "ES115PBD DIDN'T GET INVN"
- 090200 DISPLAY DB-STAT
- 090300 GO TO 4050-EXIT-STDI.
- 090400 MOVE DE-CD-NAM-8823-DEC TO INV-HLD.
- 090500 MOVE INV-NM TO HDR-INV-NM.
- 090600 4005-VALIDATE-ST.
- 090700 MOVE ST-CD-HLD TO DE-CD-8822-DEC HDR-ST-CD.
- 090800 MOVE 0003 TO DE-NO-8801-DEC.
- 090900 FIND ANY CODE-DEC.
- 091000 MOVE DB-STATUS TO DB-STAT.
- 091100 IF NOT OK
- 091200 MOVE "UNKNOWN" TO HDR-ST-NM
- 091300 GO TO 4008-EXIT-ST.
- 091400 GET CODE-DEC.
- 091500 MOVE DB-STATUS TO DB-STAT.
- 091600 IF NOT OK
- 091700 DISPLAY "ES115PBD 3 DIDN'T GET ST"
- 091800 DISPLAY "ES115PBD 4 " DB-STAT
- 091900 GO TO 4008-EXIT-ST.
- 092000 MOVE DE-CD-NAM-8823-DEC TO FUNC-HLD.
- 092100 MOVE ST-NM-HLD TO HDR-ST-NM.
- 092200 4008-EXIT-ST.
- 092300 EXIT.
- 092400 4010-VALIDATE-STDI.
- 092500 MOVE ST-DIST-CD TO DE-CD-8822-DEC.
- 092600 MOVE DI-CD-HLD TO HDR-DIST-CD.
- 092700 MOVE 0003 TO DE-NO-8801-DEC.
- 092800 FIND ANY CODE-DEC.
- 092900 MOVE DB-STATUS TO DB-STAT.
- 093000 IF NOT OK
- 093100 MOVE "UNKNOWN" TO HDR-DIST-NM
- 093200 GO TO 4050-EXIT-STDI.
- 093300 GET CODE-DEC.
- 093400 MOVE DB-STATUS TO DB-STAT.
- 093500 IF NOT OK
- 093600 DISPLAY "ES115PBD 5 DIDN'T GET STDI"
- 093700 DISPLAY "ES115PBD 6 " DB-STAT
- 093800 GO TO 4050-EXIT-STDI.
- 093900 FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
- 094000 MOVE DB-STATUS TO DB-STAT.
- 094100 IF NOT OK
- 094200 MOVE "UNKNOWN" TO HDR-DIST-NM
- 094300 GO TO 4050-EXIT-STDI.
- 094400 GET CODE-EXPL-DECE.
- 094500 MOVE DB-STATUS TO DB-STAT.
- 094600 IF NOT OK
- 094700 DISPLAY "ES115PBD 7 DIDN'T GET DIST"
- 094800 DISPLAY "ES115PBD 8 " DB-STAT
- 094900 GO TO 4050-EXIT-STDI.
- 095000 MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HLD
- 095100 MOVE DIST-NM-HLD TO HDR-DIST-NM.
- 095200 4050-EXIT-STDI.
- 095300 EXIT.
- 095400 4100-CHK-LINE-CNT.
- 095500 IF LINE-CNT > 50
- 095600 PERFORM 4200-PRT-HDNG THRU 4250-HDNG-EXIT
- 095700 GO TO 4150-EXIT-LINE-OVR50.
- 095800 4150-EXIT-LINE-OVR50.
- 095900 EXIT.
- 096000 4200-PRT-HDNG.
- 096100 ADD 1 TO PAGE-CNT.
- 096200 MOVE PAGE-CNT TO HDR-PG.
- 096300 WRITE PRT-REC FROM HDR-1 AFTER ADVANCING PAGE.
- 096400 WRITE PRT-REC FROM HDR-2 AFTER ADVANCING 1 LINES.
- 096500 WRITE PRT-REC FROM HDR-3 AFTER ADVANCING 1 LINES.
- 096600 MOVE 2 TO LINE-CNT.
- 096700 4220-CHK-WHAT-REC.
- 096800 IF HLD-REC-TYPE = "V6"
- 096900 MOVE "V6" TO HDR-REC-TYPE
- 097000 WRITE PRT-REC FROM HDR-4 AFTER ADVANCING 1 LINES
- 097100 WRITE PRT-REC FROM HDR-5-V6 AFTER ADVANCING 2 LINES
- 097200 WRITE PRT-REC FROM HDR-6-V6 AFTER ADVANCING 1 LINES
- 097300 WRITE PRT-REC FROM HDR-7-V6 AFTER ADVANCING 1 LINES
- 097400 WRITE PRT-REC FROM HDR-8-V6 AFTER ADVANCING 1 LINES
- 097500 WRITE PRT-REC FROM HDR-9-V6 AFTER ADVANCING 1 LINES
- 097600 GO TO 4230-PRT-SPACES.
- 097700 IF HLD-REC-TYPE = "V7"
- 097800 MOVE "V7" TO HDR-REC-TYPE
- 097900 WRITE PRT-REC FROM HDR-4 AFTER ADVANCING 1 LINES
- 098000 WRITE PRT-REC FROM HDR-5-V7 AFTER ADVANCING 2 LINES
- 098100 WRITE PRT-REC FROM HDR-6-V7 AFTER ADVANCING 1 LINES
- 098200 WRITE PRT-REC FROM HDR-7-V7 AFTER ADVANCING 1 LINES
- 098300 WRITE PRT-REC FROM HDR-8-V7 AFTER ADVANCING 1 LINES
- 098400 WRITE PRT-REC FROM HDR-9-V7 AFTER ADVANCING 1 LINES
- 098500 GO TO 4230-PRT-SPACES.
- 098600 IF HLD-REC-TYPE = "VF"
- 098700 MOVE "VF" TO HDR-REC-TYPE
- 098800 WRITE PRT-REC FROM HDR-4 AFTER ADVANCING 1 LINES
- 098900 WRITE PRT-REC FROM HDR-5-VF AFTER ADVANCING 2 LINES
- 099000 WRITE PRT-REC FROM HDR-6-VF AFTER ADVANCING 1 LINES
- 099100 WRITE PRT-REC FROM HDR-7-VF AFTER ADVANCING 1 LINES
- 099200 WRITE PRT-REC FROM HDR-8-VF AFTER ADVANCING 1 LINES
- 099300 WRITE PRT-REC FROM HDR-9-VF AFTER ADVANCING 1 LINES
- 099400 GO TO 4230-PRT-SPACES.
- 099500 IF HLD-REC-TYPE = "VP"
- 099600 MOVE "VP" TO HDR-REC-TYPE
- 099700 WRITE PRT-REC FROM HDR-4 AFTER ADVANCING 1 LINES
- 099800 WRITE PRT-REC FROM HDR-5-VP AFTER ADVANCING 2 LINES
- 099900 WRITE PRT-REC FROM HDR-6-VP AFTER ADVANCING 1 LINES
- 100000 WRITE PRT-REC FROM HDR-7-VP AFTER ADVANCING 1 LINES
- 100100 WRITE PRT-REC FROM HDR-8-VP AFTER ADVANCING 1 LINES
- 100200 WRITE PRT-REC FROM HDR-9-VP AFTER ADVANCING 1 LINES
- 100300 GO TO 4230-PRT-SPACES.
- 100400 IF HLD-REC-TYPE = "VU"
- 100500 MOVE "VU" TO HDR-REC-TYPE
- 100600 WRITE PRT-REC FROM HDR-4 AFTER ADVANCING 1 LINES
- 100700 WRITE PRT-REC FROM HDR-5-VU AFTER ADVANCING 2 LINES
- 100800 WRITE PRT-REC FROM HDR-6-VU AFTER ADVANCING 1 LINES
- 100900 WRITE PRT-REC FROM HDR-7-VU AFTER ADVANCING 1 LINES
- 101000 WRITE PRT-REC FROM HDR-8-VU AFTER ADVANCING 1 LINES
- 101100 WRITE PRT-REC FROM HDR-9-VU AFTER ADVANCING 1 LINES.
- 101200 4230-PRT-SPACES.
- 101300 MOVE SPACES TO PRT-REC.
- 101400 WRITE PRT-REC AFTER ADVANCING 1 LINES.
- 101500 ADD 7 TO LINE-CNT.
- 101600 4250-HDNG-EXIT.
- 101700 EXIT.
- 101800 4300-DET-REC-LINE.
- 101900 IF REC-TYPE-3529-V6-S1 = HLD-REC-TYPE
- 102000 PERFORM 4400-PRNT-DET-LINE THRU 4450-EXIT-CHK-REC-TYP
- 102100 GO TO 4320-RET-SORT.
- 102200 IF REC-TYPE-3529-V6-S1 = "99" GO TO 4350-EXIT-RET.
- 102300 MOVE 66 TO LINE-CNT.
- 102400 MOVE 0 TO PAGE-CNT.
- 102500 MOVE REC-TYPE-3529-V6-S1 TO HLD-REC-TYPE.
- 102600 PERFORM 4400-PRNT-DET-LINE THRU 4450-EXIT-CHK-REC-TYP.
- 102700 4320-RET-SORT.
- 102800 RETURN SORT-FILE AT END MOVE 1 TO EOR-SWITCH
- 102900 MOVE "99" TO REC-TYPE-3529-V6-S1.
- 103000 IF (EOR-SWITCH = 1) GO TO 4350-EXIT-RET.
- 103100 4350-EXIT-RET.
- 103200 EXIT.
- 103300 4400-PRNT-DET-LINE.
- 103400 PERFORM 4100-CHK-LINE-CNT THRU 4150-EXIT-LINE-OVR50.
- 103500 IF HLD-REC-TYPE = "V6"
- 103600 PERFORM 4500-PRNT-V6 THRU 4800-EXIT-PRT-DET
- 103700 GO TO 4450-EXIT-CHK-REC-TYP.
- 103800 IF HLD-REC-TYPE = "V7"
- 103900 PERFORM 4550-PRNT-V7 THRU 4800-EXIT-PRT-DET
- 104000 GO TO 4450-EXIT-CHK-REC-TYP.
- 104100 IF HLD-REC-TYPE = "VF"
- 104200 PERFORM 4600-PRNT-VF THRU 4800-EXIT-PRT-DET
- 104300 GO TO 4450-EXIT-CHK-REC-TYP.
- 104400 IF HLD-REC-TYPE = "VP"
- 104500 PERFORM 4650-PRNT-VP THRU 4800-EXIT-PRT-DET
- 104600 GO TO 4450-EXIT-CHK-REC-TYP.
- 104700 IF HLD-REC-TYPE = "VU"
- 104800 PERFORM 4700-PRNT-VU THRU 4800-EXIT-PRT-DET
- 104900 GO TO 4450-EXIT-CHK-REC-TYP.
- 105000 4450-EXIT-CHK-REC-TYP.
- 105100 EXIT.
- 105200 4500-PRNT-V6.
- 105300 MOVE REC-TYPE-3529-V6-S1 TO REC-TYPE-3529-V6-P1.
- 105400 MOVE FMT-NO-3576-V6-S1 TO FMT-NO-3576-V6-P1.
- 105500 MOVE FMT-CD-3579-V6-S1 TO FMT-CD-3579-V6-P1.
- 105600 MOVE ADM-ST-0003-V6-S1 TO ADM-ST-0003-V6-P1.
- 105700 MOVE ADM-DI-0003-V6-S1 TO ADM-DI-0003-V6-P1.
- 105800 MOVE ADM-RA-0003-V6-S1 TO ADM-RA-0003-V6-P1.
- 105900 MOVE ADM-PU-0003-V6-S1 TO ADM-PU-0003-V6-P1.
- 106000 MOVE DATA-DT-6618-V6-S1 TO DATA-DT-6618-V6-P1.
- 106100 MOVE ACT-CD-7350-V6-S1 TO ACT-CD-7350-V6-P1.
- 106200 MOVE LINE-NO-3578-V6-S1 TO LINE-NO-3578-V6-P1.
- 106300 MOVE PLANT-CD-2646-V6-S1 TO PLANT-CD-2646-V6-P1.
- 106400 MOVE PHNO-STG-CD-3712-V6-S1 TO PHNO-STG-CD-3712-V6-P1.
- 106500 MOVE GRAMS-GRN-WGT-3941-V6-S1 TO GRAMS-GRN-WGT-3941-V6-P1.
- 106600 MOVE ADW-PCT-3546-V6-S1 TO ADW-PCT-3546-V6-P1.
- 106700 MOVE GRAMS-DRY-WGT-3942-V6-S1 TO GRAMS-DRY-WGT-3942-V6-P1.
- 106800 IF BA-DIMS-MIN-3533-V6-S1 NOT = SPACES
- 106900 MOVE BA-DIMS-MIN-RE-3533-V6-S1 TO
- 107000 BA-DIMS-MIN-RE-3533-V6-P1
- 107100 ELSE
- 107200 MOVE BA-DIMS-MIN-3533-V6-S1 TO BA-DIMS-MIN-3533-V6-P1.
- 107300 IF BA-DIMS-MAX-3533-V6-S1 NOT = SPACES
- 107400 MOVE BA-DIMS-MAX-RE-3533-V6-S1 TO
- 107500 BA-DIMS-MAX-RE-3533-V6-P1
- 107600 ELSE
- 107700 MOVE BA-DIMS-MAX-3533-V6-S1 TO BA-DIMS-MAX-3533-V6-P1.
- 107800 IF CRN-DIMS-MIN-3534-V6-S1 NOT = SPACES
- 107900 MOVE CRN-DIMS-MIN-RE-3534-V6-S1 TO
- 108000 CRN-DIMS-MIN-RE-3534-V6-P1
- 108100 ELSE
- 108200 MOVE CRN-DIMS-MIN-3534-V6-S1 TO CRN-DIMS-MIN-3534-V6-P1.
- 108300 IF CRN-DIMS-MAX-3534-V6-S1 NOT = SPACES
- 108400 MOVE CRN-DIMS-MAX-RE-3534-V6-S1 TO
- 108500 CRN-DIMS-MAX-RE-3534-V6-P1
- 108600 ELSE
- 108700 MOVE CRN-DIMS-MAX-3534-V6-S1 TO CRN-DIMS-MAX-3534-V6-P1.
- 108800 IF HGT-AVG-3504-V6-S1 NOT = SPACES
- 108900 MOVE HGT-AVG-RE-3504-V6-S1 TO HGT-AVG-RE-3504-V6-P1
- 109000 ELSE
- 109100 MOVE HGT-AVG-3504-V6-S1 TO HGT-AVG-3504-V6-P1.
- 109200 IF AVG-LDR-LGT-7313-V6-S1 NOT = SPACES
- 109300 MOVE AVG-LDR-LGT-RE-7313-V6-S1 TO
- 109400 AVG-LDR-LGT-RE-7313-V6-P1
- 109500 ELSE
- 109600 MOVE AVG-LDR-LGT-7313-V6-S1 TO AVG-LDR-LGT-7313-V6-P1.
- 109700 WRITE PRT-REC FROM HDR-10-DET-V6 AFTER ADVANCING 2 LINES.
- 109800 ADD 2 TO LINE-CNT.
- 109900 GO TO 4800-EXIT-PRT-DET.
- 110000 4550-PRNT-V7.
- 110100 MOVE REC-TYPE-3529-V7-S1 TO REC-TYPE-3529-V7-P1.
- 110200 MOVE FMT-NO-3576-V7-S1 TO FMT-NO-3576-V7-P1.
- 110300 MOVE FMT-CD-3579-V7-S1 TO FMT-CD-3579-V7-P1.
- 110400 MOVE ADM-ST-0003-V7-S1 TO ADM-ST-0003-V7-P1.
- 110500 MOVE ADM-DI-0003-V7-S1 TO ADM-DI-0003-V7-P1.
- 110600 MOVE ADM-RA-0003-V7-S1 TO ADM-RA-0003-V7-P1.
- 110700 MOVE ADM-PU-0003-V7-S1 TO ADM-PU-0003-V7-P1.
- 110800 MOVE DATA-DT-6618-V7-S1 TO DATA-DT-6618-V7-P1.
- 110900 MOVE ACT-CD-7350-V7-S1 TO ACT-CD-7350-V7-P1.
- 111000 MOVE LINE-NO-3578-V7-S1 TO LINE-NO-3578-V7-P1.
- 111100 MOVE PLANT-CD-2646-V7-S1 (1) TO PLANT-CD1-2646-V7-P1.
- 111200 MOVE PLANT-CD-2646-V7-S1 (2) TO PLANT-CD2-2646-V7-P1.
- 111300 MOVE PLANT-CD-2646-V7-S1 (3) TO PLANT-CD3-2646-V7-P1.
- 111400 MOVE PLANT-CD-2646-V7-S1 (4) TO PLANT-CD4-2646-V7-P1.
- 111500 MOVE PLANT-CD-2646-V7-S1 (5) TO PLANT-CD5-2646-V7-P1.
- 111600 MOVE PLANT-CD-2646-V7-S1 (6) TO PLANT-CD6-2646-V7-P1.
- 111700 MOVE PLANT-CD-2646-V7-S1 (7) TO PLANT-CD7-2646-V7-P1.
- 111800 MOVE PLANT-CD-2646-V7-S1 (8) TO PLANT-CD8-2646-V7-P1.
- 111900 MOVE PLANT-CD-2646-V7-S1 (9) TO PLANT-CD9-2646-V7-P1.
- 112000 WRITE PRT-REC FROM HDR-10-DET-V7 AFTER ADVANCING 2 LINES.
- 112100 ADD 2 TO LINE-CNT.
- 112200 GO TO 4800-EXIT-PRT-DET.
- 112300 4600-PRNT-VF.
- 112400 MOVE REC-TYPE-3529-VF-S1 TO REC-TYPE-3529-VF-P1.
- 112500 MOVE FMT-NO-3576-VF-S1 TO FMT-NO-3576-VF-P1.
- 112600 MOVE FMT-CD-3579-VF-S1 TO FMT-CD-3579-VF-P1.
- 112700 MOVE ADM-ST-0003-VF-S1 TO ADM-ST-0003-VF-P1.
- 112800 MOVE ADM-DI-0003-VF-S1 TO ADM-DI-0003-VF-P1.
- 112900 MOVE DATA-DT-6618-VF-S1 TO DATA-DT-6618-VF-P1.
- 113000 MOVE ACT-CD-7350-VF-S1 TO ACT-CD-7350-VF-P1.
- 113100 MOVE LINE-NO-3578-VF-S1 TO LINE-NO-3578-VF-P1.
- 113200 MOVE ANML-GRZG-CD-3929-VF-S1 TO ANML-GRZG-CD-3929-VF-P1.
- 113300 PERFORM 4620-VALIDATE-ANML-CD THRU 4630-EXIT-ANML-CD.
- 113400 MOVE MON-FORG-RQMT-3551-VF-S1 TO MON-FORG-RQMT-3551-VF-P1.
- 113500 PERFORM 4610-CHK-HGT-CLS THRU 4615-EXIT-HGT-CLS.
- 113600 WRITE PRT-REC FROM HDR-10-DET-VF AFTER ADVANCING 2 LINES.
- 113700 ADD 2 TO LINE-CNT.
- 113800 GO TO 4800-EXIT-PRT-DET.
- 113900 4610-CHK-HGT-CLS.
- 114000 IF ANML-HGT-CLS-CD-3548-VF-S1 = "1"
- 114100 MOVE SPACES TO ANML-HGT-3-4-3548-VF-P1
- 114200 ANML-HGT-4-7-3548-VF-P1
- 114300 ANML-HGT-7-OVR-3548-VF-P1
- 114400 MOVE "1" TO ANML-HGT-0-3-3548-VF-P1
- 114500 GO TO 4615-EXIT-HGT-CLS.
- 114600 IF ANML-HGT-CLS-CD-3548-VF-S1 = "2"
- 114700 MOVE SPACES TO ANML-HGT-0-3-3548-VF-P1
- 114800 ANML-HGT-4-7-3548-VF-P1
- 114900 ANML-HGT-7-OVR-3548-VF-P1
- 115000 MOVE "2" TO ANML-HGT-3-4-3548-VF-P1
- 115100 GO TO 4615-EXIT-HGT-CLS.
- 115200 IF ANML-HGT-CLS-CD-3548-VF-S1 = "3"
- 115300 MOVE SPACES TO ANML-HGT-0-3-3548-VF-P1
- 115400 ANML-HGT-3-4-3548-VF-P1
- 115500 ANML-HGT-7-OVR-3548-VF-P1
- 115600 MOVE "3" TO ANML-HGT-4-7-3548-VF-P1
- 115700 GO TO 4615-EXIT-HGT-CLS.
- 115800 IF ANML-HGT-CLS-CD-3548-VF-S1 = "4"
- 115900 MOVE SPACES TO ANML-HGT-0-3-3548-VF-P1
- 116000 ANML-HGT-3-4-3548-VF-P1
- 116100 ANML-HGT-4-7-3548-VF-P1
- 116200 MOVE "4" TO ANML-HGT-7-OVR-3548-VF-P1
- 116300 GO TO 4615-EXIT-HGT-CLS.
- 116400 4615-EXIT-HGT-CLS.
- 116500 EXIT.
- 116600 4620-VALIDATE-ANML-CD.
- 116700 MOVE ANML-GRZG-CD-3929-VF-S1 TO DE-CD-8822-DEC.
- 116800 MOVE 3929 TO DE-NO-8801-DEC.
- 116900 FIND ANY CODE-DEC.
- 117000 MOVE DB-STATUS TO DB-STAT.
- 117100 IF NOT OK
- 117200 MOVE "UNKNOWN" TO ANML-GRZG-NAME-VF-P1
- 117300 GO TO 4630-EXIT-ANML-CD.
- 117400 GET CODE-DEC.
- 117500 MOVE DB-STATUS TO DB-STAT.
- 117600 IF NOT OK
- 117700 DISPLAY "ES115PBD 9 DIDN'T GET SPECIES CD"
- 117800 DISPLAY "ES115PBD 10 " DB-STAT
- 117900 GO TO 4630-EXIT-ANML-CD.
- 118000 MOVE DE-CD-NAM-8823-DEC TO ANML-GRZG-NAME-VF-P1.
- 118100 4630-EXIT-ANML-CD.
- 118200 EXIT.
- 118300 4650-PRNT-VP.
- 118400 MOVE REC-TYPE-3529-VP-S1 TO REC-TYPE-3529-VP-P1.
- 118500 MOVE FMT-NO-3576-VP-S1 TO FMT-NO-3576-VP-P1.
- 118600 MOVE FMT-CD-3579-VP-S1 TO FMT-CD-3579-VP-P1.
- 118700 MOVE ADM-ST-0003-VP-S1 TO ADM-ST-0003-VP-P1.
- 118800 MOVE ADM-DI-0003-VP-S1 TO ADM-DI-0003-VP-P1.
- 118900 MOVE ADM-RA-0003-VP-S1 TO ADM-RA-0003-VP-P1.
- 119000 MOVE ADM-PU-0003-VP-S1 TO ADM-PU-0003-VP-P1.
- 119100 MOVE DATA-DT-6618-VP-S1 TO DATA-DT-6618-VP-P1.
- 119200 MOVE ACT-CD-7350-VP-S1 TO ACT-CD-7350-VP-P1.
- 119300 MOVE LINE-NO-3578-VP-S1 TO LINE-NO-3578-VP-P1.
- 119400 MOVE PLANT-CD-2646-VP-S1 TO PLANT-CD-2646-VP-P1.
- 119500 IF PHNO-ADJ-FCTR-3545-VP-S1 (1) NOT = SPACES
- 119600 MOVE PHNO-ADJ-FCTR-RE-3545-VP-S1 (1) TO
- 119700 PHNO-ADJ-FCTR1-3545-VP-P1
- 119800 ELSE
- 119900 MOVE PHNO-ADJ-FCTR-3545-VP-S1 (1) TO
- 120000 PHNO-ADJ-FCTR1-RE-3545-VP-P1.
- 120100 IF PHNO-ADJ-FCTR-3545-VP-S1 (2) NOT = SPACES
- 120200 MOVE PHNO-ADJ-FCTR-RE-3545-VP-S1 (2) TO
- 120300 PHNO-ADJ-FCTR2-3545-VP-P1
- 120400 ELSE
- 120500 MOVE PHNO-ADJ-FCTR-3545-VP-S1 (2) TO
- 120600 PHNO-ADJ-FCTR2-RE-3545-VP-P1.
- 120700 IF PHNO-ADJ-FCTR-3545-VP-S1 (3) NOT = SPACES
- 120800 MOVE PHNO-ADJ-FCTR-RE-3545-VP-S1 (3) TO
- 120900 PHNO-ADJ-FCTR3-3545-VP-P1
- 121000 ELSE
- 121100 MOVE PHNO-ADJ-FCTR-3545-VP-S1 (3) TO
- 121200 PHNO-ADJ-FCTR3-RE-3545-VP-P1.
- 121300 IF PHNO-ADJ-FCTR-3545-VP-S1 (4) NOT = SPACES
- 121400 MOVE PHNO-ADJ-FCTR-RE-3545-VP-S1 (4) TO
- 121500 PHNO-ADJ-FCTR4-3545-VP-P1
- 121600 ELSE
- 121700 MOVE PHNO-ADJ-FCTR-3545-VP-S1 (4) TO
- 121800 PHNO-ADJ-FCTR4-RE-3545-VP-P1.
- 121900 IF PHNO-ADJ-FCTR-3545-VP-S1 (5) NOT = SPACES
- 122000 MOVE PHNO-ADJ-FCTR-RE-3545-VP-S1 (5) TO
- 122100 PHNO-ADJ-FCTR5-3545-VP-P1
- 122200 ELSE
- 122300 MOVE PHNO-ADJ-FCTR-3545-VP-S1 (5) TO
- 122400 PHNO-ADJ-FCTR5-RE-3545-VP-P1.
- 122500 IF PHNO-ADJ-FCTR-3545-VP-S1 (6) NOT = SPACES
- 122600 MOVE PHNO-ADJ-FCTR-RE-3545-VP-S1 (6) TO
- 122700 PHNO-ADJ-FCTR6-3545-VP-P1
- 122800 ELSE
- 122900 MOVE PHNO-ADJ-FCTR-3545-VP-S1 (6) TO
- 123000 PHNO-ADJ-FCTR6-RE-3545-VP-P1.
- 123100 IF PHNO-ADJ-FCTR-3545-VP-S1 (7) NOT = SPACES
- 123200 MOVE PHNO-ADJ-FCTR-RE-3545-VP-S1 (7) TO
- 123300 PHNO-ADJ-FCTR7-3545-VP-P1
- 123400 ELSE
- 123500 MOVE PHNO-ADJ-FCTR-3545-VP-S1 (7) TO
- 123600 PHNO-ADJ-FCTR7-RE-3545-VP-P1.
- 123700 IF PHNO-ADJ-FCTR-3545-VP-S1 (8) NOT = SPACES
- 123800 MOVE PHNO-ADJ-FCTR-RE-3545-VP-S1 (8) TO
- 123900 PHNO-ADJ-FCTR8-3545-VP-P1
- 124000 ELSE
- 124100 MOVE PHNO-ADJ-FCTR-3545-VP-S1 (8) TO
- 124200 PHNO-ADJ-FCTR8-RE-3545-VP-P1.
- 124300 WRITE PRT-REC FROM HDR-10-DET-VP AFTER ADVANCING 2 LINES.
- 124400 ADD 2 TO LINE-CNT.
- 124500 GO TO 4800-EXIT-PRT-DET.
- 124600 4700-PRNT-VU.
- 124700 MOVE REC-TYPE-3529-VU-S1 TO REC-TYPE-3529-VU-P1.
- 124800 MOVE FMT-NO-3576-VU-S1 TO FMT-NO-3576-VU-P1.
- 124900 MOVE FMT-CD-3579-VU-S1 TO FMT-CD-3579-VU-P1.
- 125000 MOVE ADM-ST-0003-VU-S1 TO ADM-ST-0003-VU-P1.
- 125100 MOVE ADM-DI-0003-VU-S1 TO ADM-DI-0003-VU-P1.
- 125200 MOVE ADM-RA-0003-VU-S1 TO ADM-RA-0003-VU-P1.
- 125300 MOVE ADM-PU-0003-VU-S1 TO ADM-PU-0003-VU-P1.
- 125400 MOVE DATA-DT-6618-VU-S1 TO DATA-DT-6618-VU-P1.
- 125500 MOVE ACT-CD-7350-VU-S1 TO ACT-CD-7350-VU-P1.
- 125600 MOVE LINE-NO-3578-VU-S1 TO LINE-NO-3578-VU-P1.
- 125700 MOVE PLANT-CD-2646-VU-S1 TO PLANT-CD-2646-VU-P1.
- 125800 MOVE AUF-3928-VU-S1 (1) TO AUF1-3928-VU-P1.
- 125900 MOVE AUF-3928-VU-S1 (2) TO AUF2-3928-VU-P1.
- 126000 MOVE AUF-3928-VU-S1 (3) TO AUF3-3928-VU-P1.
- 126100 MOVE AUF-3928-VU-S1 (4) TO AUF4-3928-VU-P1.
- 126200 MOVE AUF-3928-VU-S1 (5) TO AUF5-3928-VU-P1.
- 126300 MOVE ANML-GRZG-CD-3929-VU-S1 TO ANML-GRZG-CD-3929-VU-P1.
- 126400 MOVE DUF-3917-VU-S1 TO DUF-3917-VU-P1.
- 126500 MOVE PUF-3511-VU-S1 (1) TO PUF1-3511-VU-P1.
- 126600 MOVE PUF-3511-VU-S1 (2) TO PUF2-3511-VU-P1.
- 126700 MOVE PUF-3511-VU-S1 (3) TO PUF3-3511-VU-P1.
- 126800 MOVE PUF-3511-VU-S1 (4) TO PUF4-3511-VU-P1.
- 126900 MOVE PUF-3511-VU-S1 (5) TO PUF5-3511-VU-P1.
- 127000 WRITE PRT-REC FROM HDR-10-DET-VU AFTER ADVANCING 2 LINES.
- 127100 ADD 2 TO LINE-CNT.
- 127200 4800-EXIT-PRT-DET.
- 127300 EXIT.
- 127400 DUMMY-SECTION.
- 127500 4830-DUMMY.
- 127600 EXIT.
- 127700 END-OF-JOB.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES120E.
- 000300* EDIT/UPDATE OF PLANTS (PHENO/WEIGHTS), ANIMALS (FORAGE/US
- 000400* FACTORS - V6, VF, VU, VP FORMATS.
- 000500*
- 000600 AUTHOR. RON BAKER.
- 000700 DATE-WRITTEN. 08/23/79.
- 000800 DATE-COMPILED.
- 000900 ENVIRONMENT DIVISION.
- 001000 CONFIGURATION SECTION.
- 001100 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001200 OBJECT-COMPUTER. LEVEL-66-ASCII, SEQUENCE IS EBCDIC.
- 001300 INPUT-OUTPUT SECTION.
- 001400 FILE-CONTROL.
- 001500 SELECT FILE-D2 ASSIGN TO D1
- 001600 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001700 SELECT FILE-D1 ASSIGN TO I1
- 001800 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001900 SELECT FILE-P1 ASSIGN TO P1
- 002000 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002100 DATA DIVISION.
- 002200 SUB-SCHEMA SECTION.
- 002300 DB CODVAL2 WITHIN BLMDIC.
- 002400 FILE SECTION.
- 002500 FD FILE-D1
- 002600 CODE-SET IS GBCD
- 002700 LABEL RECORDS ARE STANDARD
- 002800 DATA RECORD IS FDR-D1.
- 002900 01 FDR-D1 PIC X(66).
- 003000 FD FILE-D2
- 003100 CODE-SET IS GBCD
- 003200 LABEL RECORDS ARE STANDARD
- 003300 DATA RECORD IS FDR-D2.
- 003400 01 FDR-D2 PIC X(66).
- 003500 FD FILE-P1
- 003600 CODE-SET IS GBCD
- 003700 LABEL RECORDS ARE STANDARD
- 003800 DATA RECORD IS FDR-P1.
- 003900 01 FDR-P1 PIC X(132).
- 004000 WORKING-STORAGE SECTION.
- 004100 77 ADST-CD-FLG PIC 9 COMP-4.
- 004200 77 DATA-DAT-CHG-FLG PIC 9 COMP-4.
- 004300 77 DATA-DAT-FLG PIC 9 COMP-4 VALUE ZERO.
- 004400 77 DIST-CD-FLG PIC 9 COMP-4.
- 004500 77 FRC-FLG PIC 9 COMP-4.
- 004600 77 INGR-FLG PIC 9 COMP-4.
- 004700 77 KEY-FLG PIC 9 COMP-4.
- 004800 77 ERR-FLG PIC 9 COMP-4 VALUE ZERO.
- 004900 77 AST-FLG PIC 9 COMP-4 VALUE ZERO.
- 005000 77 LIN-CHK PIC 99 COMP-4.
- 005100 77 LIN-CNT PIC 99 COMP-4.
- 005200 77 PHNO-CNT PIC 99 COMP-4.
- 005300 77 LIN-FLG PIC 9 COMP-4 VALUE ZERO.
- 005400 77 PAG-CNT PIC 999 COMP-4.
- 005500 77 PUF-CNT PIC 999 COMP-4.
- 005600 77 AUF-CNT PIC 999 COMP-4.
- 005700 77 PLANT-CD-FLG PIC 9 COMP-4.
- 005800 77 ANML-CD-FLG PIC 9 COMP-4.
- 005900 77 PLANT-TYP-FLG PIC 9 COMP-4.
- 006000 77 PLU-CD-FLG PIC 9 COMP-4.
- 006100 77 RITE-HDR-FLG PIC 9 COMP-4.
- 006200 77 RITE-KEY-FLG PIC 9 COMP-4.
- 006300 77 TEST-SW PIC 9 VALUE 0 COMP-4.
- 006400 77 HEAD-SW PIC 9 VALUE 0 COMP-4.
- 006500 77 SUB PIC 99 COMP-4.
- 006600 77 REC-SUB PIC 99 COMP-4.
- 006700 77 RASUB PIC 9 COMP-4.
- 006800 77 PHNO-SUB PIC 9 COMP-4.
- 006900 01 FDR-D1-WK.
- 007000 03 CNTL-D1.
- 007100 05 REC-TYP-D1 PIC XXXX.
- 007200 05 SDRP-D1.
- 007300 07 SDR-D1.
- 007400 09 SD-D1.
- 007500 11 ST-D1 PIC XX.
- 007600 11 DIST-D1 PIC XX.
- 007700 09 RA-D1 PIC XX.
- 007800 07 PLU-D1 PIC XX.
- 007900 05 DATE-D1 PIC X(6).
- 008000 05 ACTN-D1 PIC X.
- 008100 05 DIET-D1 PIC X.
- 008200 03 DATA-D1 PIC X(46).
- 008300 01 REC-TABLE.
- 008400 03 FILLER PIC X(66) VALUE
- 008500 "VP1DUT084806790901A0001ELSA 1122XXXX556677880099".
- 008600 03 FILLER PIC X(66) VALUE
- 008700 "VP1DUT089806790901A0002BADONE 11223344556677880099".
- 008800 03 FILLER PIC X(66) VALUE
- 008900 "VP1DUT084806790901A0003ELSA ".
- 009000 03 FILLER PIC X(66) VALUE
- 009100 "VP1DUT084806790901A0004ELSA 11223344556677880099".
- 009200 03 FILLER PIC X(66) VALUE
- 009300 "VP1DUT084806790901A0005ELSA 11223344556677880099".
- 009400 03 FILLER PIC X(66) VALUE
- 009500 "VP1DUT084806790901A0006ELSA 11223344556677880099".
- 009600 03 FILLER PIC X(66) VALUE
- 009700 "VP1DUT084806790901A0007ELSA 11223344556677880099".
- 009800 03 FILLER PIC X(66) VALUE
- 009900 "VP1DUT084806790901A0008ELSA 11223344556677880099".
- 010000 03 FILLER PIC X(66) VALUE
- 010100 "VP1DUT084806790901A0009ELSA 11223344556677880099".
- 010200 03 FILLER PIC X(66) VALUE
- 010300 "VP1DUT084806790901A0010ELSA 11223344556677880099".
- 010400 03 FILLER PIC X(66) VALUE
- 010500 "VP1DUT084806790901A0011ELSA 11223344556677880099".
- 010600 03 FILLER PIC X(66) VALUE
- 010700 "VP1DUT084806790901A0012ELSA 11223344556677880099".
- 010800 03 FILLER PIC X(66) VALUE
- 010900 "VP1DUT084806790901A0013ELSA 11223344556677880099".
- 011000 03 FILLER PIC X(66) VALUE
- 011100 "VP1DUT084806790901A0014ELSA 11223344556677880099".
- 011200 03 FILLER PIC X(66) VALUE
- 011300 "VP1DUT084806790901A0015ELSA 11223344556677880099".
- 011400 03 FILLER PIC X(66) VALUE
- 011500 "VP1DUT084806790901A0016ELSA 11223344556677880099".
- 011600 03 FILLER PIC X(66) VALUE
- 011700 "VP1DUT084806790901A0017ELSA 11223344556677880099".
- 011800 03 FILLER PIC X(66) VALUE
- 011900 "VP1DUT084806790901A0018ELSA 11223344556677880099".
- 012000 03 FILLER PIC X(66) VALUE
- 012100 "VP1DUT084806790901A0019ELSA 11223344556677880099".
- 012200 03 FILLER PIC X(66) VALUE
- 012300 "VP1DUT084806790901A0020ELSA 11223344556677880099".
- 012400 03 FILLER PIC X(66) VALUE
- 012500 "VP1DUT084806790901A0021ELSA 11223344556677880099".
- 012600 03 FILLER PIC X(66) VALUE
- 012700 "VP1DUT084806790901A0022ELSA 11223344556677880099".
- 012800 03 FILLER PIC X(66) VALUE
- 012900 "VP1DUT084806790901A0023ELSA 11223344556677880099".
- 013000 03 FILLER PIC X(66) VALUE
- 013100 "VP1DUT084806790901A0024ELSA 11223344556677880099".
- 013200 03 FILLER PIC X(66) VALUE
- 013300 "VP1DUT084806790901A0025ELSA 11223344556677880099".
- 013400 03 FILLER PIC X(66) VALUE
- 013500 "VP1DUT084806790901A0026ELSA 11223344556677880099".
- 013600 03 FILLER PIC X(66) VALUE
- 013700 "VP1DUT084806790901A0027ELSA 11223344556677880099".
- 013800 03 FILLER PIC X(58) VALUE
- 013900 "V61DUT084806790901A0001ELSA 1004410000221234234545675678".
- 014000 03 FILLER PIC X(8) VALUE "91234 ".
- 014100 03 FILLER PIC X(58) VALUE
- 014200 "V61DUT084806790901A0002SSSS 9004410000221234234545675678".
- 014300 03 FILLER PIC X(8) VALUE "91234 ".
- 014400 03 FILLER PIC X(58) VALUE
- 014500 "V61DUT088806790901A0003ELSA 1004410000221234234545675678".
- 014600 03 FILLER PIC X(8) VALUE "91234 ".
- 014700 03 FILLER PIC X(58) VALUE
- 014800 "V61DUT088806790901A0004ELSA 1004410000221234234545675678".
- 014900 03 FILLER PIC X(8) VALUE "91234 ".
- 015000 03 FILLER PIC X(58) VALUE
- 015100 "V61DUT088806790901A0005ELSA 1004410000221234234545675678".
- 015200 03 FILLER PIC X(8) VALUE "91234 ".
- 015300 03 FILLER PIC X(58) VALUE
- 015400 "V61DUT088806790901A0006ELSA 1004410000221234234545675678".
- 015500 03 FILLER PIC X(8) VALUE "91234 ".
- 015600 03 FILLER PIC X(58) VALUE
- 015700 "V61DUT088806790901A0007ELSA 1004410000221234234545675678".
- 015800 03 FILLER PIC X(8) VALUE "91234 ".
- 015900 03 FILLER PIC X(58) VALUE
- 016000 "V61DUT088806790901A0008ELSA 1004410000221234234545675678".
- 016100 03 FILLER PIC X(8) VALUE "91234 ".
- 016200 03 FILLER PIC X(58) VALUE
- 016300 "V61DUT088806790901A0009ELSA 1004410000221234234545675678".
- 016400 03 FILLER PIC X(8) VALUE "91234 ".
- 016500 03 FILLER PIC X(58) VALUE
- 016600 "V61DUT088806790901A0010ELSA 1004410000221234234545675678".
- 016700 03 FILLER PIC X(8) VALUE "91234 ".
- 016800 03 FILLER PIC X(58) VALUE
- 016900 "V61DUT088806790901A0011ELSA 1004410000221234234545675678".
- 017000 03 FILLER PIC X(8) VALUE "91234 ".
- 017100 03 FILLER PIC X(58) VALUE
- 017200 "V61DUT088806790901A0012ELSA 1004410000221234234545675678".
- 017300 03 FILLER PIC X(8) VALUE "91234 ".
- 017400 03 FILLER PIC X(58) VALUE
- 017500 "V61DUT088806790901A0013ELSA 1004410000221234234545675678".
- 017600 03 FILLER PIC X(8) VALUE "91234 ".
- 017700 03 FILLER PIC X(58) VALUE
- 017800 "V61DUT088806790901A0014ELSA 1004410000221234234545675678".
- 017900 03 FILLER PIC X(8) VALUE "91234 ".
- 018000 03 FILLER PIC X(58) VALUE
- 018100 "V61DUT088806790901A0015ELSA 1004410000221234234545675678".
- 018200 03 FILLER PIC X(8) VALUE "91234 ".
- 018300 03 FILLER PIC X(58) VALUE
- 018400 "V61DUT088806790901A0016ELSA 1004410000221234234545675678".
- 018500 03 FILLER PIC X(8) VALUE "91234 ".
- 018600 03 FILLER PIC X(58) VALUE
- 018700 "V61DUT088806790901A0017ELSA 1004410000221234234545675678".
- 018800 03 FILLER PIC X(8) VALUE "91234 ".
- 018900 03 FILLER PIC X(58) VALUE
- 019000 "V61DUT088806790901A0018ELSA 1004410000221234234545675678".
- 019100 03 FILLER PIC X(8) VALUE "91234 ".
- 019200 03 FILLER PIC X(58) VALUE
- 019300 "V61DUT088806790901A0019ELSA 1004410000221234234545675678".
- 019400 03 FILLER PIC X(8) VALUE "91234 ".
- 019500 03 FILLER PIC X(58) VALUE
- 019600 "V61DUT088806790901A0020ELSA 1004410000221234234545675678".
- 019700 03 FILLER PIC X(8) VALUE "91234 ".
- 019800 03 FILLER PIC X(58) VALUE
- 019900 "V61DUT088806790901A0021ELSA 1004410000221234234545675678".
- 020000 03 FILLER PIC X(8) VALUE "91234 ".
- 020100 03 FILLER PIC X(58) VALUE
- 020200 "V61DUT088806790901A0022ELSA 1004410000221234234545675678".
- 020300 03 FILLER PIC X(8) VALUE "91234 ".
- 020400 03 FILLER PIC X(58) VALUE
- 020500 "V61DUT088806790901A0023ELSA 1004410000221234234545675678".
- 020600 03 FILLER PIC X(8) VALUE "91234 ".
- 020700 03 FILLER PIC X(58) VALUE
- 020800 "V61DUT088806790901A0024ELSA 1004410000221234234545675678".
- 020900 03 FILLER PIC X(8) VALUE "91234 ".
- 021000 03 FILLER PIC X(58) VALUE
- 021100 "V61DUT088806790901A0025ELSA 1004410000221234234545675678".
- 021200 03 FILLER PIC X(8) VALUE "91234 ".
- 021300 03 FILLER PIC X(58) VALUE
- 021400 "V61DUT088806790901A0026ELSA 1004410000221234234545675678".
- 021500 03 FILLER PIC X(8) VALUE "91234 ".
- 021600 03 FILLER PIC X(58) VALUE
- 021700 "V61DUT088806790901A0027ELSA 1004410000221234234545675678".
- 021800 03 FILLER PIC X(8) VALUE "91234 ".
- 021900 03 FILLER PIC X(58) VALUE
- 022000 "V61DUT088806790901A0028ELSA 1004410000221234234545675678".
- 022100 03 FILLER PIC X(8) VALUE "91234 ".
- 022200 03 FILLER PIC X(66) VALUE
- 022300 "VF1DUT08 790901A0001CA12343".
- 022400 03 FILLER PIC X(66) VALUE
- 022500 "VF1DUT08 790901A0002ACAAAA9".
- 022600 03 FILLER PIC X(66) VALUE
- 022700 "VU1DUT084806790901AC0001BADONE 123456789123456CA00123456".
- 022800 03 FILLER PIC X(66) VALUE
- 022900 "VU1DUT084806790901AD0002PIED BAD 789123456AC00BB3456".
- 023000 03 FILLER PIC X(66) VALUE
- 023100 "VU1DUT084806790901AP0003ELSA 123456789123456CA00123456".
- 023200 03 FILLER PIC X(66) VALUE
- 023300 "END ".
- 023400 03 FILLER PIC X(66) VALUE
- 023500 "END ".
- 023600 03 FILLER PIC X(66) VALUE
- 023700 "END ".
- 023800 01 REC-TAB-RD REDEFINES REC-TABLE.
- 023900 03 REC-TB OCCURS 63 TIMES.
- 024000 05 RT-RT PIC XXXX.
- 024100 05 DATA-RT PIC X(62).
- 024200* "VF" FORAGE REQUIREMENT DATA.
- 024400 01 REC-VF-X.
- 024500 05 KEY-VF-X.
- 024600 10 DIC-VF-X.
- 024700 15 REC-TYP-3529-VF-X PIC X(2).
- 024800 15 FMT-NUM-3576-VF-X PIC X(1).
- 024900 15 FMT-CD-3579-VF-X PIC X(1).
- 025000 10 BLM-ADM-U-0003-VF-X.
- 025100 15 BLM-ADM-U-0003-ST-VF-X PIC X(2).
- 025200 15 BLM-ADM-U-0003-DIST-VF-X PIC X(2).
- 025300 15 FILLER PIC XXXX.
- 025400 10 DATA-DATE-6618-VF-X.
- 025500 15 DATA-DATE-6618-YY-VF-X PIC X(2).
- 025600 15 DATA-DATE-6618-MM-VF-X PIC X(2).
- 025700 15 DATA-DATE-6618-DD-VF-X PIC X(2).
- 025800 10 ACTN-CD-7350-VF-X PIC X(1).
- 025900 10 LIN-NUM-3578-VF-X PIC X(4).
- 026000*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- 026100 05 ANML-GRZG-CD-3929-VF-X PIC X(2).
- 026200 05 MON-FORG-RQMT-LBS-3551-VF-X PIC X(4).
- 026300 05 ANML-HGT-CLS-CD-3548-VF-X PIC X(1).
- 026400 05 FILLER PIC X(36).
- 026600 01 REC-VF-Z.
- 026700 05 KEY-VF-Z.
- 026800 10 DIC-VF-Z.
- 026900 15 REC-TYP-3529-VF-Z PIC X(2).
- 027000 15 FMT-NUM-3576-VF-Z PIC X(1).
- 027100 15 FMT-CD-3579-VF-Z PIC X(1).
- 027200 10 BLM-ADM-U-0003-VF-Z.
- 027300 15 BLM-ADM-U-0003-ST-VF-Z PIC X(2).
- 027400 15 BLM-ADM-U-0003-DIST-VF-Z PIC X(2).
- 027500 15 FILLER PIC XXXX.
- 027600 10 DATA-DATE-6618-VF-Z.
- 027700 15 DATA-DATE-6618-YY-VF-Z PIC X(2).
- 027800 15 DATA-DATE-6618-MM-VF-Z PIC X(2).
- 027900 15 DATA-DATE-6618-DD-VF-Z PIC X(2).
- 028000 10 ACTN-CD-7350-VF-Z PIC X(1).
- 028100 10 LIN-NUM-3578-VF-Z PIC X(4).
- 028200*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- 028300 05 ANML-GRZG-CD-3929-VF-Z PIC X(2).
- 028400 05 MON-FORG-RQMT-LBS-3551-VF-Z PIC X(4).
- 028500 05 ANML-HGT-CLS-CD-3548-VF-Z PIC X(1).
- 028600 05 FILLER PIC X(36).
- 028700******************************************************************
- 028800* "VP" PHENOLOGY ADJUSTMENT DATA.
- 029000 01 REC-VP-X.
- 029100 05 KEY-VP-X.
- 029200 10 DIC-VP-X.
- 029300 15 REC-TYP-3529-VP-X PIC X(2).
- 029400 15 FMT-NUM-3576-VP-X PIC X(1).
- 029500 15 FMT-CD-3579-VP-X PIC X(1).
- 029600 10 BLM-ADM-U-0003-VP-X.
- 029700 15 BLM-ADM-U-0003-ST-VP-X PIC X(2).
- 029800 15 BLM-ADM-U-0003-DIST-VP-X PIC X(2).
- 029900 15 BLM-ADM-U-0003-RA-VP-X PIC X(2).
- 030000 15 BLM-ADM-U-0003-PLU-VP-X PIC X(2).
- 030100 10 DATA-DATE-6618-VP-X.
- 030200 15 DATA-DATE-6618-YY-VP-X PIC X(2).
- 030300 15 DATA-DATE-6618-MM-VP-X PIC X(2).
- 030400 15 DATA-DATE-6618-DD-VP-X PIC X(2).
- 030500 10 ACTN-CD-7350-VP-X PIC X(1).
- 030600 10 LIN-NUM-3578-VP-X PIC X(4).
- 030700*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- 030800 05 PLANT-CD-2646-VP-X PIC X(7).
- 030900 05 PHNO-GP-VP-X PIC X(32).
- 031000 05 PHNO-ADJ-GP-VP-X REDEFINES PHNO-GP-VP-X.
- 031100 07 PHNO-ADJ-VP-X OCCURS 8 TIMES.
- 031200 09 PHNO-ADJ-1-VP-X PIC XX.
- 031300 09 PHNO-ADJ-2-VP-X PIC XX.
- 031400 05 PHNO-ADJ-FCTR-3545-VP-X REDEFINES PHNO-GP-VP-X
- 031500 OCCURS 8 TIMES PIC 99V99.
- 031600 05 PLANT-TYP-3590-VP-X PIC X.
- 031700 05 FILLER PIC XXXX.
- 031900 01 REC-VP-Z.
- 032000 05 KEY-VP-Z.
- 032100 10 DIC-VP-Z.
- 032200 15 REC-TYP-3529-VP-Z PIC X(2).
- 032300 15 FMT-NUM-3576-VP-Z PIC X(1).
- 032400 15 FMT-CD-3579-VP-Z PIC X(1).
- 032500 10 BLM-ADM-U-0003-VP-Z.
- 032600 15 BLM-ADM-U-0003-ST-VP-Z PIC X(2).
- 032700 15 BLM-ADM-U-0003-DIST-VP-Z PIC X(2).
- 032800 15 BLM-ADM-U-0003-RA-VP-Z PIC X(2).
- 032900 15 BLM-ADM-U-0003-PLU-VP-Z PIC X(2).
- 033000 10 DATA-DATE-6618-VP-Z.
- 033100 15 DATA-DATE-6618-YY-VP-Z PIC X(2).
- 033200 15 DATA-DATE-6618-MM-VP-Z PIC X(2).
- 033300 15 DATA-DATE-6618-DD-VP-Z PIC X(2).
- 033400 10 ACTN-CD-7350-VP-Z PIC X(1).
- 033500 10 LIN-NUM-3578-VP-Z PIC X(4).
- 033600*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- 033700 05 PLANT-CD-2646-VP-Z PIC X(7).
- 033800 05 PHNO-GP-VP-Z PIC X(32).
- 033900 05 PHNO-ADJ-GP-VP-Z REDEFINES PHNO-GP-VP-Z.
- 034000 07 PHNO-ADJ-VP-Z OCCURS 8 TIMES.
- 034100 09 PHNO-ADJ-1-VP-Z PIC XX.
- 034200 09 PHNO-ADJ-2-VP-Z PIC XX.
- 034300 05 PHNO-ADJ-FCTR-3545-VP-Z REDEFINES PHNO-GP-VP-Z
- 034400 OCCURS 8 TIMES PIC 99V99.
- 034500 05 PLANT-TYP-3590-VP-Z PIC X.
- 034600 05 FILLER PIC XXXX.
- 034700******************************************************************
- 034800* "VU1D" DIET AND USE FACTORS BY ANIMAL AND SEASON.
- 035000 01 REC-VU-X.
- 035100 05 KEY-VU-X.
- 035200 10 DIC-VU-X.
- 035300 15 REC-TYP-3529-VU-X PIC X(2).
- 035400 15 FMT-NUM-3576-VU-X PIC X(1).
- 035500 15 FMT-CD-3579-VU-X PIC X(1).
- 035600 10 BLM-ADM-U-0003-VU-X.
- 035700 15 BLM-ADM-U-0003-ST-VU-X PIC X(2).
- 035800 15 BLM-ADM-U-0003-DIST-VU-X PIC X(2).
- 035900 15 BLM-ADM-U-0003-RA-VU-X PIC X(2).
- 036000 15 BLM-ADM-U-0003-PLU-VU-X PIC X(2).
- 036100 10 DATA-DATE-6618-VU-X.
- 036200 15 DATA-DATE-6618-YY-VU-X PIC X(2).
- 036300 15 DATA-DATE-6618-MM-VU-X PIC X(2).
- 036400 15 DATA-DATE-6618-DD-VU-X PIC X(2).
- 036500 10 ACTN-CD-7350-VU-X PIC X(1).
- 036600 10 DIET-USE-TYP-3917-VU-X PIC X(1).
- 036700 10 LIN-NUM-3578-VU-X PIC X(4).
- 036800*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- 036900 05 PLANT-CD-2646-VU-X PIC X(7).
- 037000 05 AUF-3928-VU-X-RD PIC X(15).
- 037100 05 AUF-3928-VU-X REDEFINES AUF-3928-VU-X-RD
- 037200 OCCURS 5 TIMES PIC XXX.
- 037300 05 ANML-GRZG-CD-3929-VU-X PIC X(2).
- 037400 05 PUF-3511-VU-X-RD PIC X(10).
- 037500 05 PUF-3511-VU-X REDEFINES PUF-3511-VU-X-RD
- 037600 OCCURS 5 TIMES PIC XX.
- 037700 05 PLANT-TYP-3590-VU-X PIC X.
- 037800 05 FILLER PIC X(8).
- 037900 01 REC-VU-Z.
- 038000 05 KEY-VU-Z.
- 038100 10 DIC-VU-Z.
- 038200 15 REC-TYP-3529-VU-Z PIC X(2).
- 038300 15 FMT-NUM-3576-VU-Z PIC X(1).
- 038400 15 FMT-CD-3579-VU-Z PIC X(1).
- 038500 10 BLM-ADM-U-0003-VU-Z.
- 038600 15 BLM-ADM-U-0003-ST-VU-Z PIC X(2).
- 038700 15 BLM-ADM-U-0003-DIST-VU-Z PIC X(2).
- 038800 15 BLM-ADM-U-0003-RA-VU-Z PIC X(2).
- 038900 15 BLM-ADM-U-0003-PLU-VU-Z PIC X(2).
- 039000 10 DATA-DATE-6618-VU-Z.
- 039100 15 DATA-DATE-6618-YY-VU-Z PIC X(2).
- 039200 15 DATA-DATE-6618-MM-VU-Z PIC X(2).
- 039300 15 DATA-DATE-6618-DD-VU-Z PIC X(2).
- 039400 10 ACTN-CD-7350-VU-Z PIC X(1).
- 039500 10 DIET-USE-TYP-3917-VU-Z PIC X(1).
- 039600 10 LIN-NUM-3578-VU-Z PIC X(4).
- 039700*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- 039800 05 PLANT-CD-2646-VU-Z PIC X(7).
- 039900 05 AUF-3928-VU-Z OCCURS 5 TIMES PIC X(3).
- 040000 05 ANML-GRZG-CD-3929-VU-Z PIC X(2).
- 040100 05 PUF-3511-VU-Z OCCURS 5 TIMES PIC X(2).
- 040200 05 PLANT-TYP-3590-VU-Z PIC X.
- 040300 05 FILLER PIC X(8).
- 040400******************************************************************
- 040500* "V6" DRY/GREEN WEIGHT CONVERSION FACTOR DATA.
- 040700 01 REC-V6-X.
- 040800 05 KEY-V6-X.
- 040900 10 DIC-V6-X.
- 041000 15 REC-TYP-3529-V6-X PIC X(2).
- 041100 15 FMT-NUM-3576-V6-X PIC X(1).
- 041200 15 FMT-CD-3579-V6-X PIC X(1).
- 041300 10 BLM-ADM-U-0003-V6-X.
- 041400 15 BLM-ADM-U-0003-ST-V6-X PIC X(2).
- 041500 15 BLM-ADM-U-0003-DIST-V6-X PIC X(2).
- 041600 15 BLM-ADM-U-0003-RA-V6-X PIC X(2).
- 041700 15 BLM-ADM-U-0003-PLU-V6-X PIC X(2).
- 041800 10 DATA-DATE-6618-V6-X.
- 041900 15 DATA-DATE-6618-YY-V6-X PIC X(2).
- 042000 15 DATA-DATE-6618-MM-V6-X PIC X(2).
- 042100 15 DATA-DATE-6618-DD-V6-X PIC X(2).
- 042200 10 ACTN-CD-7350-V6-X PIC X(1).
- 042300 10 LIN-NUM-3578-V6-X PIC X(4).
- 042400*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- 042500 05 PLANT-CD-2646-V6-X PIC X(7).
- 042600 05 PHNO-STG-CD-3712-V6-X PIC X(1).
- 042700 05 GRAMS-GRN-WGT-3941-V6-X PIC X(4).
- 042800 05 ADW-PCT-3546-V6-X PIC X(3).
- 042900 05 GRAMS-DRY-WGT-3942-V6-X PIC X(4).
- 043000 05 GRP-1-V6-X.
- 043100 07 BASAL-DIMS-3533-MIN-V6-X PIC 99V99.
- 043200 07 BASAL-DIMS-3533-MAX-V6-X PIC 99V99.
- 043300 07 CROWN-DIMS-3534-MIN-V6-X PIC 99V9.
- 043400 07 CROWN-DIMS-3534-MAX-V6-X PIC 99V9.
- 043500 07 HGT-AVG-3504-V6-X PIC 999V9.
- 043600 07 AVG-LDR-LGT-7313-V6-X PIC 99V9.
- 043700 05 GRP-1-RD-V6-X REDEFINES GRP-1-V6-X.
- 043800 07 BASAL-DIMS-MIN-V6-X.
- 043900 09 BAD-MIN-1-V6-X PIC XX.
- 044000 09 BAD-MIN-2-V6-X PIC XX.
- 044100 07 BASAL-DIMS-MAX-V6-X.
- 044200 09 BAD-MAX-1-V6-X PIC XX.
- 044300 09 BAD-MAX-2-V6-X PIC XX.
- 044400 07 CROWN-DIMS-MIN-V6-X.
- 044500 09 CRD-MIN-1-V6-X PIC XX.
- 044600 09 CRD-MIN-2-V6-X PIC X.
- 044700 07 CROWN-DIMS-MAX-V6-X.
- 044800 09 CRD-MAX-1-V6-X PIC XX.
- 044900 09 CRD-MAX-2-V6-X PIC X.
- 045000 07 HGT-AVG-V6-X.
- 045100 09 HGT-AVG-1-V6-X PIC XXX.
- 045200 09 HGT-AVG-2-V6-X PIC X.
- 045300 07 AVG-LDR-V6-X.
- 045400 09 AVG-LDR-1-V6-X PIC XX.
- 045500 09 AVG-LDR-2-V6-X PIC X.
- 045600 05 PLANT-TYP-V6-X PIC X.
- 045700 05 REC-CNT-V6-X PIC 99.
- 045800******************************************************************
- 045900 01 REC-V6-Z.
- 046000 05 KEY-V6-Z.
- 046100 10 DIC-V6-Z.
- 046200 15 REC-TYP-3529-V6-Z PIC X(2).
- 046300 15 FMT-NUM-3576-V6-Z PIC X(1).
- 046400 15 FMT-CD-3579-V6-Z PIC X(1).
- 046500 10 BLM-ADM-U-0003-V6-Z.
- 046600 15 BLM-ADM-U-0003-ST-V6-Z PIC X(2).
- 046700 15 BLM-ADM-U-0003-DIST-V6-Z PIC X(2).
- 046800 15 BLM-ADM-U-0003-RA-V6-Z PIC X(2).
- 046900 15 BLM-ADM-U-0003-PLU-V6-Z PIC X(2).
- 047000 10 DATA-DATE-6618-V6-Z.
- 047100 15 DATA-DATE-6618-YY-V6-Z PIC X(2).
- 047200 15 DATA-DATE-6618-MM-V6-Z PIC X(2).
- 047300 15 DATA-DATE-6618-DD-V6-Z PIC X(2).
- 047400 10 ACTN-CD-7350-V6-Z PIC X(1).
- 047500 10 LIN-NUM-3578-V6-Z PIC X(4).
- 047600*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- 047700 05 PLANT-CD-2646-V6-Z PIC X(7).
- 047800 05 PHNO-STG-CD-3712-V6-Z PIC X(1).
- 047900 05 GRAMS-GRN-WGT-3941-V6-Z PIC X(4).
- 048000 05 ADW-PCT-3546-V6-Z PIC X(3).
- 048100 05 GRAMS-DRY-WGT-3942-V6-Z PIC X(4).
- 048200 05 GRP-1-V6-Z.
- 048300 07 BASAL-DIMS-3533-MIN-V6-Z PIC 99V99.
- 048400 07 BASAL-DIMS-3533-MAX-V6-Z PIC 99V99.
- 048500 07 CROWN-DIMS-3534-MIN-V6-Z PIC 99V9.
- 048600 07 CROWN-DIMS-3534-MAX-V6-Z PIC 99V9.
- 048700 07 HGT-AVG-3504-V6-Z PIC 999V9.
- 048800 07 AVG-LDR-LGT-7313-V6-Z PIC 99V9.
- 048900 05 GRP-1-RD-V6-Z REDEFINES GRP-1-V6-Z.
- 049000 07 BASAL-DIMS-MIN-V6-Z PIC XXXX.
- 049100 07 BASAL-DIMS-MAX-V6-Z PIC XXXX.
- 049200 07 CROWN-DIMS-MIN-V6-Z PIC XXX.
- 049300 07 CROWN-DIMS-MAX-V6-Z PIC XXX.
- 049400 07 HGT-AVG-V6-Z PIC XXXX.
- 049500 07 AVG-LDR-V6-Z PIC XXX.
- 049600 05 PLANT-TYP-V6-Z PIC X.
- 049700 05 REC-CNT-V6-Z PIC 99.
- 049800******************************************************************
- 049900 01 REC-1-VF-P.
- 050000 05 FILLER PIC X(17) VALUE SPACE.
- 050100 05 REC-VF-P PIC XXXX.
- 050200 05 FILLER PIC X(13) VALUE SPACE.
- 050300 05 ST-VF-P PIC XX.
- 050400 05 FILLER PIC X(14) VALUE SPACE.
- 050500 05 DIST-VF-P PIC XX.
- 050600 05 FILLER PIC X(11) VALUE SPACE.
- 050700 05 DATE-VF-P PIC X(6).
- 050800 05 FILLER PIC X(13) VALUE SPACE.
- 050900 05 ACTN-VF-P PIC X.
- 051000 05 FILLER PIC X(49) VALUE SPACE.
- 051100 01 REC-1-VF-AST.
- 051200 05 FILLER PIC X(17) VALUE SPACE.
- 051300 05 REC-VF-AST PIC XXXX.
- 051400 05 FILLER PIC X(13) VALUE SPACE.
- 051500 05 ST-VF-AST PIC XX.
- 051600 05 FILLER PIC X(14) VALUE SPACE.
- 051700 05 DIST-VF-AST PIC XX.
- 051800 05 FILLER PIC X(11) VALUE SPACE.
- 051900 05 DATE-VF-AST PIC X(6).
- 052000 05 FILLER PIC X(13) VALUE SPACE.
- 052100 05 ACTN-VF-AST PIC X.
- 052200 05 FILLER PIC X(49) VALUE SPACE.
- 052300 01 REC-2-VF-P.
- 052400 05 FILLER PIC X(8) VALUE SPACE.
- 052500 05 LINE-VF-P PIC XXXX.
- 052600 05 FILLER PIC X(8) VALUE SPACE.
- 052700 05 ANML-SP-VF-P PIC XX.
- 052800 05 FILLER PIC X(8) VALUE SPACE.
- 052900 05 MON-FORG-VF-P PIC XXXX.
- 053000 05 FILLER PIC X(14) VALUE SPACE.
- 053100 05 HT-CLS-AV-VF-P PIC X.
- 053200 05 FILLER PIC X(83) VALUE SPACE.
- 053300 01 REC-2-VF-AST.
- 053400 05 FILLER PIC X(8) VALUE SPACE.
- 053500 05 LINE-VF-AST PIC XXXX.
- 053600 05 FILLER PIC X(8) VALUE SPACE.
- 053700 05 ANML-SP-VF-AST PIC XX.
- 053800 05 FILLER PIC X(8) VALUE SPACE.
- 053900 05 MON-FORG-VF-AST PIC XXXX.
- 054000 05 FILLER PIC X(14) VALUE SPACE.
- 054100 05 HT-CLS-AV-VF-AST PIC X.
- 054200 05 FILLER PIC X(83) VALUE SPACE.
- 054300******************************************************************
- 054400 01 REC-1-V6P-P.
- 054500 05 FILLER PIC X(17) VALUE SPACE.
- 054600 05 REC-V6P-P PIC XXXX.
- 054700 05 FILLER PIC X(13) VALUE SPACE.
- 054800 05 ST-V6P-P PIC XX.
- 054900 05 FILLER PIC X(14) VALUE SPACE.
- 055000 05 DIST-V6P-P PIC XX.
- 055100 05 FILLER PIC X(12) VALUE SPACE.
- 055200 05 RA-V6P-P PIC XX.
- 055300 05 FILLER PIC X(15) VALUE SPACE.
- 055400 05 PLU-V6P-P PIC XX.
- 055500 05 FILLER PIC X(13) VALUE SPACE.
- 055600 05 DATE-V6P-P PIC X(6).
- 055700 05 FILLER PIC X(13) VALUE SPACE.
- 055800 05 ACTN-V6P-P PIC X.
- 055900 05 FILLER PIC X(16) VALUE SPACE.
- 056000 01 REC-1-V6P-AST.
- 056100 05 FILLER PIC X(17) VALUE SPACE.
- 056200 05 REC-V6P-AST PIC XXXX.
- 056300 05 FILLER PIC X(13) VALUE SPACE.
- 056400 05 ST-V6P-AST PIC XX.
- 056500 05 FILLER PIC X(14) VALUE SPACE.
- 056600 05 DIST-V6P-AST PIC XX.
- 056700 05 FILLER PIC X(12) VALUE SPACE.
- 056800 05 RA-V6P-AST PIC XX.
- 056900 05 FILLER PIC X(15) VALUE SPACE.
- 057000 05 PLU-V6P-AST PIC XX.
- 057100 05 FILLER PIC X(13) VALUE SPACE.
- 057200 05 DATE-V6P-AST PIC X(6).
- 057300 05 FILLER PIC X(13) VALUE SPACE.
- 057400 05 ACTN-V6P-AST PIC X.
- 057500 05 FILLER PIC X(16) VALUE SPACE.
- 057600 01 REC-2-V6-P.
- 057700 05 FILLER PIC X(5) VALUE SPACE.
- 057800 05 LINE-V6-P PIC XXXX.
- 057900 05 FILLER PIC X(3) VALUE SPACE.
- 058000 05 PLANT-CD-V6-P PIC X(7).
- 058100 05 FILLER PIC X(4) VALUE SPACE.
- 058200 05 PHNO-V6-P PIC X.
- 058300 05 FILLER PIC X(6) VALUE SPACE.
- 058400 05 GRN-WGT-V6-P PIC XXXX.
- 058500 05 FILLER PIC X(7) VALUE SPACE.
- 058600 05 PCT-DW-V6-P PIC XXX.
- 058700 05 FILLER PIC X(7) VALUE SPACE.
- 058800 05 DW-V6-P PIC XXXX.
- 058900 05 FILLER PIC X(7) VALUE SPACE.
- 059000 05 MIN-BAD-V6-P1 PIC XX.
- 059100 05 MIN-BAD-V6-P2 PIC X.
- 059200 05 MIN-BAD-V6-P3 PIC XX.
- 059300 05 FILLER PIC X(7) VALUE SPACE.
- 059400 05 MAX-BAD-V6-P1 PIC XX.
- 059500 05 MAX-BAD-V6-P2 PIC X.
- 059600 05 MAX-BAD-V6-P3 PIC XX.
- 059700 05 FILLER PIC X(10) VALUE SPACE.
- 059800 05 MIN-CRND-V6-P1 PIC XX.
- 059900 05 MIN-CRND-V6-P2 PIC X.
- 060000 05 MIN-CRND-V6-P3 PIC X.
- 060100 05 FILLER PIC X(10) VALUE SPACE.
- 060200 05 MAX-CRND-V6-P1 PIC XX.
- 060300 05 MAX-CRND-V6-P2 PIC X.
- 060400 05 MAX-CRND-V6-P3 PIC X.
- 060500 05 FILLER PIC X(5) VALUE SPACE.
- 060600 05 HGT-V6-P1 PIC XXX.
- 060700 05 HGT-V6-P2 PIC X.
- 060800 05 HGT-V6-P3 PIC X.
- 060900 05 FILLER PIC X(7) VALUE SPACE.
- 061000 05 AVG-LDR-V6-P1 PIC XX.
- 061100 05 AVG-LDR-V6-P2 PIC X.
- 061200 05 AVG-LDR-V6-P3 PIC X.
- 061300 05 FILLER PIC XX VALUE SPACE.
- 061400 05 REC-CNT-V6-P PIC 99.
- 061500 01 REC-2-V6-AST.
- 061600 05 FILLER PIC X(5) VALUE SPACE.
- 061700 05 LINE-V6-AST PIC XXXX.
- 061800 05 FILLER PIC X(3) VALUE SPACE.
- 061900 05 PLANT-CD-V6-AST PIC X(7).
- 062000 05 FILLER PIC X(4) VALUE SPACE.
- 062100 05 PHNO-V6-AST PIC X.
- 062200 05 FILLER PIC X(6) VALUE SPACE.
- 062300 05 GRN-WGT-V6-AST PIC XXXX.
- 062400 05 FILLER PIC X(7) VALUE SPACE.
- 062500 05 PCT-DW-V6-AST PIC XXX.
- 062600 05 FILLER PIC X(7) VALUE SPACE.
- 062700 05 DW-V6-AST PIC XXXX.
- 062800 05 FILLER PIC X(7) VALUE SPACE.
- 062900 05 MIN-BAD-V6-AST PIC XXBXX.
- 063000 05 FILLER PIC X(7) VALUE SPACE.
- 063100 05 MAX-BAD-V6-AST PIC XXBXX.
- 063200 05 FILLER PIC X(10) VALUE SPACE.
- 063300 05 MIN-CRND-V6-AST PIC XXBX.
- 063400 05 FILLER PIC X(10) VALUE SPACE.
- 063500 05 MAX-CRND-V6-AST PIC XXBX.
- 063600 05 FILLER PIC X(5) VALUE SPACE.
- 063700 05 HGT-V6-AST PIC XXXBX.
- 063800 05 FILLER PIC X(7) VALUE SPACE.
- 063900 05 AVG-LDR-V6-AST PIC XXBX.
- 064000 05 FILLER PIC X(4) VALUE SPACE.
- 064100******************************************************************
- 064200 01 REC-2-VP-P.
- 064300 05 FILLER PIC X(8) VALUE SPACE.
- 064400 05 LINE-VP-P PIC XXXX.
- 064500 05 FILLER PIC X(8) VALUE SPACE.
- 064600 05 PLANT-CD-VP-P PIC X(7).
- 064700 05 FILLER PIC X(6) VALUE SPACE.
- 064800 05 PHNO-PCT-VP-P OCCURS 8 TIMES.
- 064900 07 PHNO-PCT-VP-P1 PIC XX.
- 065000 07 PHNO-PCT-VP-P2 PIC X.
- 065100 07 PHNO-PCT-VP-P3 PIC XX.
- 065200 07 FILLER PIC X(7).
- 065300 05 FILLER PIC XXX VALUE SPACE.
- 065400 01 REC-2-VP-AST.
- 065500 05 FILLER PIC X(8) VALUE SPACE.
- 065600 05 LINE-VP-AST PIC XXXX.
- 065700 05 FILLER PIC X(8) VALUE SPACE.
- 065800 05 PLANT-CD-VP-AST PIC X(7).
- 065900 05 FILLER PIC X(6) VALUE SPACE.
- 066000 05 PHNO-PCT-VP-AST OCCURS 8 TIMES PIC XXBX(9).
- 066100 05 FILLER PIC XXX VALUE SPACE.
- 066200******************************************************************
- 066300 01 REC-1-VU-P.
- 066400 05 FILLER PIC X(12) VALUE SPACE.
- 066500 05 REC-VU-P PIC XXXX.
- 066600 05 FILLER PIC X(13) VALUE SPACE.
- 066700 05 ST-VU-P PIC XX.
- 066800 05 FILLER PIC X(14) VALUE SPACE.
- 066900 05 DIST-VU-P PIC XX.
- 067000 05 FILLER PIC X(12) VALUE SPACE.
- 067100 05 RA-VU-P PIC XX.
- 067200 05 FILLER PIC X(15) VALUE SPACE.
- 067300 05 PLU-VU-P PIC XX.
- 067400 05 FILLER PIC X(13) VALUE SPACE.
- 067500 05 DATE-VU-P PIC X(6).
- 067600 05 FILLER PIC X(13) VALUE SPACE.
- 067700 05 ACTN-VU-P PIC X.
- 067800 05 FILLER PIC X(10) VALUE SPACE.
- 067900 05 PUFDT-VU-P PIC X.
- 068000 05 FILLER PIC X(10) VALUE SPACE.
- 068100 01 REC-1-VU-AST.
- 068200 05 FILLER PIC X(12) VALUE SPACE.
- 068300 05 REC-VU-AST PIC XXXX.
- 068400 05 FILLER PIC X(13) VALUE SPACE.
- 068500 05 ST-VU-AST PIC XX.
- 068600 05 FILLER PIC X(14) VALUE SPACE.
- 068700 05 DIST-VU-AST PIC XX.
- 068800 05 FILLER PIC X(12) VALUE SPACE.
- 068900 05 RA-VU-AST PIC XX.
- 069000 05 FILLER PIC X(15) VALUE SPACE.
- 069100 05 PLU-VU-AST PIC XX.
- 069200 05 FILLER PIC X(13) VALUE SPACE.
- 069300 05 DATE-VU-AST PIC X(6).
- 069400 05 FILLER PIC X(13) VALUE SPACE.
- 069500 05 ACTN-VU-AST PIC X.
- 069600 05 FILLER PIC X(10) VALUE SPACE.
- 069700 05 PUFDT-VU-AST PIC X.
- 069800 05 FILLER PIC X(10) VALUE SPACE.
- 069900 01 REC-2-VU-P.
- 070000 05 FILLER PIC X(8) VALUE SPACE.
- 070100 05 LINE-VU-P PIC XXXX.
- 070200 05 FILLER PIC X(3) VALUE SPACE.
- 070300 05 PLANT-CD-VU-P PIC X(7).
- 070400 05 FILLER PIC X(4) VALUE SPACE.
- 070500 05 AUF-GP-P.
- 070600 07 PLNT-SPG-VU-P PIC XXX.
- 070700 07 FILLER PIC X(5) VALUE SPACE.
- 070800 07 PLNT-SUM-VU-P PIC XXX.
- 070900 07 FILLER PIC X(5) VALUE SPACE.
- 071000 07 PLNT-FAL-VU-P PIC XXX.
- 071100 07 FILLER PIC X(5) VALUE SPACE.
- 071200 07 PLNT-WIN-VU-P PIC XXX.
- 071300 07 FILLER PIC X(5) VALUE SPACE.
- 071400 07 PLNT-YRL-VU-P PIC XXX.
- 071500 07 FILLER PIC X(5) VALUE SPACE.
- 071600 05 AUF-GP-RD-P REDEFINES AUF-GP-P OCCURS 5 TIMES.
- 071700 07 AUF-PCT-VU-P PIC XXX.
- 071800 07 FILLER PIC XXXXX.
- 071900 05 FILLER PIC XXX.
- 072000 05 ANML-SP-VU-P PIC XX.
- 072100 05 FILLER PIC X(7) VALUE SPACE.
- 072200 05 PUF-GP-P.
- 072300 07 ANML-SPG-VU-P PIC XX.
- 072400 07 FILLER PIC X(7) VALUE SPACE.
- 072500 07 ANML-SUM-VU-P PIC XX.
- 072600 07 FILLER PIC X(7) VALUE SPACE.
- 072700 07 ANML-FAL-VU-P PIC XX.
- 072800 07 FILLER PIC X(7) VALUE SPACE.
- 072900 07 ANML-WIN-VU-P PIC XX.
- 073000 07 FILLER PIC X(7) VALUE SPACE.
- 073100 07 ANML-YRL-VU-P PIC XX.
- 073200 07 FILLER PIC X(7) VALUE SPACE.
- 073300 05 PUF-GP-RD-P REDEFINES PUF-GP-P OCCURS 5 TIMES.
- 073400 07 PUF-VU-P PIC XX.
- 073500 07 FILLER PIC X(7).
- 073600 05 FILLER PIC X(8) VALUE SPACE.
- 073700******************************************************************
- 073800 01 REC-2-VU-AST.
- 073900 05 FILLER PIC X(8) VALUE SPACE.
- 074000 05 LINE-VU-AST PIC XXXX.
- 074100 05 FILLER PIC X(3) VALUE SPACE.
- 074200 05 PLANT-CD-VU-AST PIC X(7).
- 074300 05 FILLER PIC X(4) VALUE SPACE.
- 074400 05 AUF-GP-AST.
- 074500 07 PLNT-SPG-VU-AST PIC XXX.
- 074600 07 FILLER PIC X(5) VALUE SPACE.
- 074700 07 PLNT-SUM-VU-AST PIC XXX.
- 074800 07 FILLER PIC X(5) VALUE SPACE.
- 074900 07 PLNT-FAL-VU-AST PIC XXX.
- 075000 07 FILLER PIC X(5) VALUE SPACE.
- 075100 07 PLNT-WIN-VU-AST PIC XXX.
- 075200 07 FILLER PIC X(5) VALUE SPACE.
- 075300 07 PLNT-YRL-VU-AST PIC XXX.
- 075400 07 FILLER PIC X(5) VALUE SPACE.
- 075500 05 AUF-GP-RD-AST REDEFINES AUF-GP-AST OCCURS 5 TIMES.
- 075600 07 AUF-PCT-VU-AST PIC XXX.
- 075700 07 FILLER PIC XXXXX.
- 075800 05 FILLER PIC XXX.
- 075900 05 ANML-SP-VU-AST PIC XX.
- 076000 05 FILLER PIC X(7) VALUE SPACE.
- 076100 05 PUF-GP-AST.
- 076200 07 ANML-SPG-VU-AST PIC XX.
- 076300 07 FILLER PIC X(7) VALUE SPACE.
- 076400 07 ANML-SUM-VU-AST PIC XX.
- 076500 07 FILLER PIC X(7) VALUE SPACE.
- 076600 07 ANML-FAL-VU-AST PIC XX.
- 076700 07 FILLER PIC X(7) VALUE SPACE.
- 076800 07 ANML-WIN-VU-AST PIC XX.
- 076900 07 FILLER PIC X(7) VALUE SPACE.
- 077000 07 ANML-YRL-VU-AST PIC XX.
- 077100 07 FILLER PIC X(7) VALUE SPACE.
- 077200 05 PUF-GP-RD-AST REDEFINES PUF-GP-AST OCCURS 5 TIMES.
- 077300 07 PUF-VU-AST PIC XX.
- 077400 07 FILLER PIC X(7).
- 077500 05 FILLER PIC X(8) VALUE SPACE.
- 077600******************************************************************
- 077700*01 REC-2-VU-AST.
- 077800* 05 FILLER PIC X(8) VALUE SPACE.
- 077900* 05 LINE-VP-AST PIC XXXX.
- 078000* 05 FILLER PIC X(3) VALUE SPACE.
- 078100* 05 PLANT-CD-VU-AST PIC X(7).
- 078200* 05 FILLER PIC X(3) VALUE SPACE.
- 078300* 05 PLNT-SPG-VU-AST PIC XXX.
- 078400* 05 FILLER PIC X(6) VALUE SPACE.
- 078500* 05 PLNT-SUM-VU-AST PIC XXX.
- 078600* 05 FILLER PIC X(5) VALUE SPACE.
- 078700* 05 PLNT-FAL-VU-AST PIC XXX.
- 078800* 05 FILLER PIC X(5) VALUE SPACE.
- 078900* 05 PLNT-WIN-VU-AST PIC XXX.
- 079000* 05 FILLER PIC X(5) VALUE SPACE.
- 079100* 05 PLNT-YRL-VU-AST PIC XXX.
- 079200* 05 FILLER PIC X(8) VALUE SPACE.
- 079300* 05 ANML-SP-VU-AST PIC XX.
- 079400* 05 FILLER PIC X(7) VALUE SPACE.
- 079500* 05 ANML-SPG-VU-AST PIC XX.
- 079600* 05 FILLER PIC X(7) VALUE SPACE.
- 079700* 05 ANML-SUM-VU-AST PIC XX.
- 079800* 05 FILLER PIC X(7) VALUE SPACE.
- 079900* 05 ANML-FAL-VU-AST PIC XX.
- 080000* 05 FILLER PIC X(7) VALUE SPACE.
- 080100* 05 ANML-WIN-VU-AST PIC XX.
- 080200* 05 FILLER PIC X(7) VALUE SPACE.
- 080300* 05 ANML-YRL-VU-AST PIC XX.
- 080400* 05 FILLER PIC X(15) VALUE SPACE.
- 080500******************************************************************
- 080600 01 HDR-1.
- 080700 05 FILLER PIC X(24) VALUE " PCN: ES120E AS OF ".
- 080800 05 HDR-DD PIC XX.
- 080900 05 FILLER PIC X VALUE SPACE.
- 081000 05 HDR-MMM PIC XXX.
- 081100 05 FILLER PIC X VALUE SPACE.
- 081200 05 HDR-YR PIC XX.
- 081300 05 FILLER PIC X(09) VALUE SPACES.
- 081400 05 FILLER PIC X(48) VALUE
- 081500 "USDI- BUR OF LAND MGT ECOLOGICAL SITE INVENTORY".
- 081600 05 FILLER PIC X(31) VALUE SPACES.
- 081700 05 FILLER PIC X(5) VALUE "PAGE:".
- 081800 05 HDR-PG PIC ZZZZZ9.
- 081900 01 HDR-2.
- 082000 05 FILLER PIC X(17) VALUE SPACES.
- 082100 05 FILLER PIC X(8) VALUE "STATE: ".
- 082200 05 HDR-ST-NM PIC X(10).
- 082300 05 FILLER PIC X(16) VALUE SPACES.
- 082400 05 FILLER PIC X(7) VALUE "DIST: ".
- 082500 05 HDR-DIST-NM PIC X(15).
- 082600 05 FILLER PIC X(15) VALUE SPACES.
- 082700 05 RMK-HDR-2 PIC X(22) VALUE SPACE.
- 082800 05 FILLER PIC X(17) VALUE SPACES.
- 082900 01 HDR-3 PIC X(132).
- 083000 01 HDR-4 PIC X(132).
- 083100 01 VU-HDR-REC1.
- 083200 03 FILLER PIC X(10) VALUE SPACE.
- 083300 03 FILLER PIC X(7) VALUE "REC TYP".
- 083400 03 FILLER PIC X(12) VALUE SPACE.
- 083500 03 FILLER PIC X(2) VALUE "ST".
- 083600 03 FILLER PIC X(12) VALUE SPACE.
- 083700 03 FILLER PIC X(4) VALUE "DIST".
- 083800 03 FILLER PIC X(12) VALUE SPACE.
- 083900 03 FILLER PIC X(2) VALUE "RA".
- 084000 03 FILLER PIC X(14) VALUE SPACE.
- 084100 03 FILLER PIC X(3) VALUE "PLU".
- 084200 03 FILLER PIC X(14) VALUE SPACE.
- 084300 03 FILLER PIC X(4) VALUE "DATE".
- 084400 03 FILLER PIC X(12) VALUE SPACE.
- 084500 03 FILLER PIC X(4) VALUE "ACTN".
- 084600 03 FILLER PIC X(6) VALUE SPACE.
- 084700 03 FILLER PIC X(7) VALUE "PUF/DPV".
- 084800 03 FILLER PIC X(7) VALUE SPACE.
- 084900 01 VU-HDR-REC2.
- 085000 03 FILLER PIC X(10) VALUE SPACE.
- 085100 03 FILLER PIC X(7) VALUE " 1-4 ".
- 085200 03 FILLER PIC X(11) VALUE SPACE.
- 085300 03 FILLER PIC X(3) VALUE "5-6".
- 085400 03 FILLER PIC X(13) VALUE SPACE.
- 085500 03 FILLER PIC X(3) VALUE "7-8".
- 085600 03 FILLER PIC X(11) VALUE SPACE.
- 085700 03 FILLER PIC X(4) VALUE "9-10".
- 085800 03 FILLER PIC X(12) VALUE SPACE.
- 085900 03 FILLER PIC X(5) VALUE "11-12".
- 086000 03 FILLER PIC X(12) VALUE SPACE.
- 086100 03 FILLER PIC X(5) VALUE "13-18".
- 086200 03 FILLER PIC X(12) VALUE SPACE.
- 086300 03 FILLER PIC X(4) VALUE " 19 ".
- 086400 03 FILLER PIC X(6) VALUE SPACE.
- 086500 03 FILLER PIC X(7) VALUE " 20 ".
- 086600 03 FILLER PIC X(7) VALUE SPACE.
- 086700 01 VU-HDR-REC3.
- 086800 03 FILLER PIC X(10) VALUE SPACE.
- 086900 03 FILLER PIC X(7) VALUE " XXXX ".
- 087000 03 FILLER PIC X(11) VALUE SPACE.
- 087100 03 FILLER PIC X(3) VALUE " XX".
- 087200 03 FILLER PIC X(13) VALUE SPACE.
- 087300 03 FILLER PIC X(3) VALUE " XX".
- 087400 03 FILLER PIC X(11) VALUE SPACE.
- 087500 03 FILLER PIC X(4) VALUE " XX ".
- 087600 03 FILLER PIC X(12) VALUE SPACE.
- 087700 03 FILLER PIC X(5) VALUE " XX ".
- 087800 03 FILLER PIC X(12) VALUE SPACE.
- 087900 03 FILLER PIC X(6) VALUE "XXXXXX".
- 088000 03 FILLER PIC X(12) VALUE SPACE.
- 088100 03 FILLER PIC X(4) VALUE " X ".
- 088200 03 FILLER PIC X(6) VALUE SPACE.
- 088300 03 FILLER PIC X(7) VALUE " X ".
- 088400 03 FILLER PIC X(7) VALUE SPACE.
- 088500 01 VF-HDR-REC1.
- 088600 03 FILLER PIC X(15) VALUE SPACE.
- 088700 03 FILLER PIC X(7) VALUE "REC TYP".
- 088800 03 FILLER PIC X(12) VALUE SPACE.
- 088900 03 FILLER PIC X(2) VALUE "ST".
- 089000 03 FILLER PIC X(12) VALUE SPACE.
- 089100 03 FILLER PIC X(4) VALUE "DIST".
- 089200 03 FILLER PIC X(12) VALUE SPACE.
- 089300 03 FILLER PIC X(4) VALUE "DATE".
- 089400 03 FILLER PIC X(12) VALUE SPACE.
- 089500 03 FILLER PIC X(4) VALUE "ACTN".
- 089600 03 FILLER PIC X(50) VALUE SPACE.
- 089700 01 VF-HDR-REC2.
- 089800 03 FILLER PIC X(15) VALUE SPACE.
- 089900 03 FILLER PIC X(7) VALUE " 1-4 ".
- 090000 03 FILLER PIC X(11) VALUE SPACE.
- 090100 03 FILLER PIC X(3) VALUE "5-6".
- 090200 03 FILLER PIC X(13) VALUE SPACE.
- 090300 03 FILLER PIC X(3) VALUE "7-8".
- 090400 03 FILLER PIC X(11) VALUE SPACE.
- 090500 03 FILLER PIC X(5) VALUE "13-18".
- 090600 03 FILLER PIC X(12) VALUE SPACE.
- 090700 03 FILLER PIC X(4) VALUE " 19 ".
- 090800 03 FILLER PIC X(50) VALUE SPACE.
- 090900 01 VF-HDR-REC3.
- 091000 03 FILLER PIC X(15) VALUE SPACE.
- 091100 03 FILLER PIC X(7) VALUE " XXXX ".
- 091200 03 FILLER PIC X(11) VALUE SPACE.
- 091300 03 FILLER PIC X(3) VALUE " XX".
- 091400 03 FILLER PIC X(13) VALUE SPACE.
- 091500 03 FILLER PIC X(3) VALUE " XX".
- 091600 03 FILLER PIC X(11) VALUE SPACE.
- 091700 03 FILLER PIC X(6) VALUE "XXXXXX".
- 091800 03 FILLER PIC X(11) VALUE SPACE.
- 091900 03 FILLER PIC X(4) VALUE " X ".
- 092000 03 FILLER PIC X(48) VALUE SPACE.
- 092100 01 V6P-HDR-REC1.
- 092200 03 FILLER PIC X(15) VALUE SPACE.
- 092300 03 FILLER PIC X(7) VALUE "REC TYP".
- 092400 03 FILLER PIC X(12) VALUE SPACE.
- 092500 03 FILLER PIC X(2) VALUE "ST".
- 092600 03 FILLER PIC X(12) VALUE SPACE.
- 092700 03 FILLER PIC X(4) VALUE "DIST".
- 092800 03 FILLER PIC X(12) VALUE SPACE.
- 092900 03 FILLER PIC X(2) VALUE "RA".
- 093000 03 FILLER PIC X(14) VALUE SPACE.
- 093100 03 FILLER PIC X(3) VALUE "PLU".
- 093200 03 FILLER PIC X(14) VALUE SPACE.
- 093300 03 FILLER PIC X(4) VALUE "DATE".
- 093400 03 FILLER PIC X(12) VALUE SPACE.
- 093500 03 FILLER PIC X(4) VALUE "ACTN".
- 093600 03 FILLER PIC X(15) VALUE SPACE.
- 093700 01 V6P-HDR-REC2.
- 093800 03 FILLER PIC X(15) VALUE SPACE.
- 093900 03 FILLER PIC X(7) VALUE " 1-4 ".
- 094000 03 FILLER PIC X(11) VALUE SPACE.
- 094100 03 FILLER PIC X(3) VALUE "5-6".
- 094200 03 FILLER PIC X(13) VALUE SPACE.
- 094300 03 FILLER PIC X(3) VALUE "7-8".
- 094400 03 FILLER PIC X(11) VALUE SPACE.
- 094500 03 FILLER PIC X(4) VALUE "9-10".
- 094600 03 FILLER PIC X(12) VALUE SPACE.
- 094700 03 FILLER PIC X(5) VALUE "11-12".
- 094800 03 FILLER PIC X(12) VALUE SPACE.
- 094900 03 FILLER PIC X(5) VALUE "13-18".
- 095000 03 FILLER PIC X(12) VALUE SPACE.
- 095100 03 FILLER PIC X(4) VALUE " 19 ".
- 095200 03 FILLER PIC X(20) VALUE SPACE.
- 095300 01 V6P-HDR-REC3.
- 095400 03 FILLER PIC X(15) VALUE SPACE.
- 095500 03 FILLER PIC X(7) VALUE " XXXX ".
- 095600 03 FILLER PIC X(11) VALUE SPACE.
- 095700 03 FILLER PIC X(3) VALUE " XX".
- 095800 03 FILLER PIC X(13) VALUE SPACE.
- 095900 03 FILLER PIC X(3) VALUE " XX".
- 096000 03 FILLER PIC X(11) VALUE SPACE.
- 096100 03 FILLER PIC X(5) VALUE " XX ".
- 096200 03 FILLER PIC X(12) VALUE SPACE.
- 096300 03 FILLER PIC X(5) VALUE " XX ".
- 096400 03 FILLER PIC X(11) VALUE SPACE.
- 096500 03 FILLER PIC X(6) VALUE "XXXXXX".
- 096600 03 FILLER PIC X(11) VALUE SPACE.
- 096700 03 FILLER PIC X(4) VALUE " X ".
- 096800 03 FILLER PIC X(20) VALUE SPACE.
- 096900***********************************************************
- 097000**********************************************************
- 097100***********************************************************
- 097200 01 VF-HDR-REC4.
- 097300 03 FILLER PIC X(6) VALUE SPACE.
- 097400 03 FILLER PIC X(7) VALUE "LIN NUM".
- 097500 03 FILLER PIC X(4) VALUE SPACE.
- 097600 03 FILLER PIC X(7) VALUE "ANML SP".
- 097700 03 FILLER PIC XXXX VALUE SPACE.
- 097800 03 FILLER PIC X(8) VALUE "MON FORG".
- 097900 03 FILLER PIC XXXX VALUE SPACE.
- 098000 03 FILLER PIC X(14) VALUE "HT-CLASS AVAIL".
- 098100 03 FILLER PIC X(78) VALUE SPACE.
- 098200 01 VF-HDR-REC5.
- 098300 03 FILLER PIC X(6) VALUE SPACE.
- 098400 03 FILLER PIC X(7) VALUE " 20-23 ".
- 098500 03 FILLER PIC X(4) VALUE SPACE.
- 098600 03 FILLER PIC X(7) VALUE " 24-25 ".
- 098700 03 FILLER PIC XXXX VALUE SPACE.
- 098800 03 FILLER PIC X(8) VALUE " 26-29 ".
- 098900 03 FILLER PIC XXXX VALUE SPACE.
- 099000 03 FILLER PIC X(14) VALUE " 30 ".
- 099100 03 FILLER PIC X(78) VALUE SPACE.
- 099200 01 VF-HDR-REC6.
- 099300 03 FILLER PIC X(6) VALUE SPACE.
- 099400 03 FILLER PIC X(7) VALUE " XXXX ".
- 099500 03 FILLER PIC X(4) VALUE SPACE.
- 099600 03 FILLER PIC X(7) VALUE " XX ".
- 099700 03 FILLER PIC XXXX VALUE SPACE.
- 099800 03 FILLER PIC X(8) VALUE " XXXX ".
- 099900 03 FILLER PIC XXXX VALUE SPACE.
- 100000 03 FILLER PIC X(14) VALUE " X ".
- 100100 03 FILLER PIC X(78) VALUE SPACE.
- 100200 01 VU-HDR-REC4.
- 100300 03 FILLER PIC X(6) VALUE SPACE.
- 100400 03 FILLER PIC X(7) VALUE "LIN NUM".
- 100500 03 FILLER PIC X(2) VALUE SPACE.
- 100600 03 FILLER PIC X(7) VALUE " PLANT ".
- 100700 03 FILLER PIC X(2) VALUE SPACE.
- 100800 03 FILLER PIC X(6) VALUE "SPRING".
- 100900 03 FILLER PIC X(3) VALUE SPACE.
- 101000 03 FILLER PIC X(6) VALUE "SUMMER".
- 101100 03 FILLER PIC X(2) VALUE SPACE.
- 101200 03 FILLER PIC X(5) VALUE " FALL".
- 101300 03 FILLER PIC X(2) VALUE SPACE.
- 101400 03 FILLER PIC X(6) VALUE "WINTER".
- 101500 03 FILLER PIC X(2) VALUE SPACE.
- 101600 03 FILLER PIC X(7) VALUE "YR LONG".
- 101700 03 FILLER PIC X(3) VALUE SPACE.
- 101800 03 FILLER PIC X(7) VALUE "ANML SP".
- 101900 03 FILLER PIC X(3) VALUE SPACE.
- 102000 03 FILLER PIC X(6) VALUE "SPRING".
- 102100 03 FILLER PIC X(3) VALUE SPACE.
- 102200 03 FILLER PIC X(6) VALUE "SUMMER".
- 102300 03 FILLER PIC X(4) VALUE SPACE.
- 102400 03 FILLER PIC X(5) VALUE " FALL".
- 102500 03 FILLER PIC X(3) VALUE SPACE.
- 102600 03 FILLER PIC X(6) VALUE "WINTER".
- 102700 03 FILLER PIC X(3) VALUE SPACE.
- 102800 03 FILLER PIC X(7) VALUE "YR LONG".
- 102900 03 FILLER PIC X(7) VALUE SPACE.
- 103000 01 VU-HDR-REC5.
- 103100 03 FILLER PIC X(6) VALUE SPACE.
- 103200 03 FILLER PIC X(7) VALUE " 21-24 ".
- 103300 03 FILLER PIC X(2) VALUE SPACE.
- 103400 03 FILLER PIC X(7) VALUE " 25-31 ".
- 103500 03 FILLER PIC X(2) VALUE SPACE.
- 103600 03 FILLER PIC X(6) VALUE " 32-34".
- 103700 03 FILLER PIC X(3) VALUE SPACE.
- 103800 03 FILLER PIC X(6) VALUE "35-37 ".
- 103900 03 FILLER PIC X(2) VALUE SPACE.
- 104000 03 FILLER PIC X(5) VALUE "38-40".
- 104100 03 FILLER PIC X(2) VALUE SPACE.
- 104200 03 FILLER PIC X(6) VALUE " 41-43".
- 104300 03 FILLER PIC X(2) VALUE SPACE.
- 104400 03 FILLER PIC X(7) VALUE " 44-46 ".
- 104500 03 FILLER PIC X(3) VALUE SPACE.
- 104600 03 FILLER PIC X(7) VALUE " 47-48 ".
- 104700 03 FILLER PIC X(3) VALUE SPACE.
- 104800 03 FILLER PIC X(6) VALUE " 49-50".
- 104900 03 FILLER PIC X(3) VALUE SPACE.
- 105000 03 FILLER PIC X(6) VALUE " 51-52".
- 105100 03 FILLER PIC X(4) VALUE SPACE.
- 105200 03 FILLER PIC X(5) VALUE "53-54".
- 105300 03 FILLER PIC X(3) VALUE SPACE.
- 105400 03 FILLER PIC X(6) VALUE " 55-56".
- 105500 03 FILLER PIC X(3) VALUE SPACE.
- 105600 03 FILLER PIC X(7) VALUE " 57-58 ".
- 105700 03 FILLER PIC X(7) VALUE SPACE.
- 105800***********************************************************
- 105900 01 VU-HDR-REC6.
- 106000 03 FILLER PIC X(6) VALUE SPACE.
- 106100 03 FILLER PIC X(7) VALUE " XXXX ".
- 106200 03 FILLER PIC X(2) VALUE SPACE.
- 106300 03 FILLER PIC X(7) VALUE "XXXXXXX".
- 106400 03 FILLER PIC X(2) VALUE SPACE.
- 106500 03 FILLER PIC X(6) VALUE " XXX ".
- 106600 03 FILLER PIC X(3) VALUE SPACE.
- 106700 03 FILLER PIC X(6) VALUE " XXX ".
- 106800 03 FILLER PIC X(2) VALUE SPACE.
- 106900 03 FILLER PIC X(5) VALUE " XXX ".
- 107000 03 FILLER PIC X(2) VALUE SPACE.
- 107100 03 FILLER PIC X(6) VALUE " XXX ".
- 107200 03 FILLER PIC X(2) VALUE SPACE.
- 107300 03 FILLER PIC X(7) VALUE " XXX ".
- 107400 03 FILLER PIC X(3) VALUE SPACE.
- 107500 03 FILLER PIC X(7) VALUE " XX ".
- 107600 03 FILLER PIC X(3) VALUE SPACE.
- 107700 03 FILLER PIC X(6) VALUE " XX ".
- 107800 03 FILLER PIC X(3) VALUE SPACE.
- 107900 03 FILLER PIC X(6) VALUE " XX ".
- 108000 03 FILLER PIC X(3) VALUE SPACE.
- 108100 03 FILLER PIC X(6) VALUE " XX ".
- 108200 03 FILLER PIC X(3) VALUE SPACE.
- 108300 03 FILLER PIC X(6) VALUE " XX ".
- 108400 03 FILLER PIC X(3) VALUE SPACE.
- 108500 03 FILLER PIC X(7) VALUE " XX ".
- 108600 03 FILLER PIC X(3) VALUE SPACE.
- 108700 03 FILLER PIC X(14) VALUE SPACE.
- 108800***********************************************************
- 108900 01 V6-HDR-REC4.
- 109000 03 FILLER PIC X(3) VALUE SPACE.
- 109100 03 FILLER PIC X(7) VALUE "LIN NUM".
- 109200 03 FILLER PIC X(2) VALUE SPACE.
- 109300 03 FILLER PIC X(7) VALUE " PLANT ".
- 109400 03 FILLER PIC X(2) VALUE SPACE.
- 109500 03 FILLER PIC X(4) VALUE "PHNO".
- 109600 03 FILLER PIC X(3) VALUE SPACE.
- 109700 03 FILLER PIC X(7) VALUE "GRN WGT".
- 109800 03 FILLER PIC X(3) VALUE SPACE.
- 109900 03 FILLER PIC X(8) VALUE "%DRY WGT".
- 110000 03 FILLER PIC X(3) VALUE SPACE.
- 110100 03 FILLER PIC X(7) VALUE "DRY WGT".
- 110200 03 FILLER PIC X(3) VALUE SPACE.
- 110300 03 FILLER PIC X(10) VALUE "MIN BA-DIA".
- 110400 03 FILLER PIC X(3) VALUE SPACE.
- 110500 03 FILLER PIC X(10) VALUE "MAX BA-DIA".
- 110600 03 FILLER PIC X(3) VALUE SPACE.
- 110700 03 FILLER PIC X(11) VALUE "MIN CRN-DIA".
- 110800 03 FILLER PIC X(3) VALUE SPACE.
- 110900 03 FILLER PIC X(11) VALUE "MAX CRN-DIA".
- 111000 03 FILLER PIC X(2) VALUE SPACE.
- 111100 03 FILLER PIC X(5) VALUE " HGT ".
- 111200 03 FILLER PIC X(2) VALUE SPACE.
- 111300 03 FILLER PIC X(13) VALUE "AVG LDR CNT".
- 111400 01 V6-HDR-REC5.
- 111500 03 FILLER PIC X(3) VALUE SPACE.
- 111600 03 FILLER PIC X(7) VALUE " 20-23 ".
- 111700 03 FILLER PIC X(2) VALUE SPACE.
- 111800 03 FILLER PIC X(7) VALUE " 24-30 ".
- 111900 03 FILLER PIC X(2) VALUE SPACE.
- 112000 03 FILLER PIC X(4) VALUE " 31 ".
- 112100 03 FILLER PIC X(3) VALUE SPACE.
- 112200 03 FILLER PIC X(7) VALUE " 32-35 ".
- 112300 03 FILLER PIC X(3) VALUE SPACE.
- 112400 03 FILLER PIC X(8) VALUE " 36-38 ".
- 112500 03 FILLER PIC X(3) VALUE SPACE.
- 112600 03 FILLER PIC X(7) VALUE " 39-42 ".
- 112700 03 FILLER PIC X(3) VALUE SPACE.
- 112800 03 FILLER PIC X(10) VALUE " 43-46 ".
- 112900 03 FILLER PIC X(3) VALUE SPACE.
- 113000 03 FILLER PIC X(10) VALUE " 47-50 ".
- 113100 03 FILLER PIC X(3) VALUE SPACE.
- 113200 03 FILLER PIC X(11) VALUE " 51-53 ".
- 113300 03 FILLER PIC X(3) VALUE SPACE.
- 113400 03 FILLER PIC X(11) VALUE " 54-56 ".
- 113500 03 FILLER PIC X(2) VALUE SPACE.
- 113600 03 FILLER PIC X(5) VALUE "57-60".
- 113700 03 FILLER PIC X(2) VALUE SPACE.
- 113800 03 FILLER PIC X(13) VALUE "61-63 65-66".
- 113900 01 V6-HDR-REC6.
- 114000 03 FILLER PIC X(3) VALUE SPACE.
- 114100 03 FILLER PIC X(7) VALUE " XXXX ".
- 114200 03 FILLER PIC X(2) VALUE SPACE.
- 114300 03 FILLER PIC X(7) VALUE "XXXXXXX".
- 114400 03 FILLER PIC X(2) VALUE SPACE.
- 114500 03 FILLER PIC X(4) VALUE " X ".
- 114600 03 FILLER PIC X(3) VALUE SPACE.
- 114700 03 FILLER PIC X(7) VALUE " XXXX ".
- 114800 03 FILLER PIC X(3) VALUE SPACE.
- 114900 03 FILLER PIC X(8) VALUE " XXX ".
- 115000 03 FILLER PIC X(3) VALUE SPACE.
- 115100 03 FILLER PIC X(7) VALUE " XXXX ".
- 115200 03 FILLER PIC X(3) VALUE SPACE.
- 115300 03 FILLER PIC X(10) VALUE " XX XX ".
- 115400 03 FILLER PIC X(3) VALUE SPACE.
- 115500 03 FILLER PIC X(10) VALUE " XX XX ".
- 115600 03 FILLER PIC X(4) VALUE SPACE.
- 115700 03 FILLER PIC X(10) VALUE " XX X ".
- 115800 03 FILLER PIC X(4) VALUE SPACE.
- 115900 03 FILLER PIC X(10) VALUE " XX X ".
- 116000 03 FILLER PIC X(2) VALUE SPACE.
- 116100 03 FILLER PIC X(5) VALUE "XXX X".
- 116200 03 FILLER PIC X(2) VALUE SPACE.
- 116300 03 FILLER PIC X(13) VALUE " XX X XX".
- 116400 01 VP-HDR-REC4.
- 116500 03 FILLER PIC X(6) VALUE SPACE.
- 116600 03 FILLER PIC X(7) VALUE "LIN NUM".
- 116700 03 FILLER PIC X(7) VALUE SPACE.
- 116800 03 FILLER PIC X(7) VALUE " PLANT ".
- 116900 03 FILLER PIC X(4) VALUE SPACE.
- 117000 03 FILLER PIC X(8) VALUE "PHNO-1 %".
- 117100 03 FILLER PIC X(4) VALUE SPACE.
- 117200 03 FILLER PIC X(8) VALUE "PHNO-2 %".
- 117300 03 FILLER PIC X(4) VALUE SPACE.
- 117400 03 FILLER PIC X(8) VALUE "PHNO-3 %".
- 117500 03 FILLER PIC X(4) VALUE SPACE.
- 117600 03 FILLER PIC X(8) VALUE "PHNO-4 %".
- 117700 03 FILLER PIC X(4) VALUE SPACE.
- 117800 03 FILLER PIC X(8) VALUE "PHNO-5 %".
- 117900 03 FILLER PIC X(4) VALUE SPACE.
- 118000 03 FILLER PIC X(8) VALUE "PHNO-6 %".
- 118100 03 FILLER PIC X(4) VALUE SPACE.
- 118200 03 FILLER PIC X(8) VALUE "PHNO-7 %".
- 118300 03 FILLER PIC X(4) VALUE SPACE.
- 118400 03 FILLER PIC X(8) VALUE "PHNO-8 %".
- 118500 03 FILLER PIC X(9) VALUE SPACE.
- 118600 01 VP-HDR-REC5.
- 118700 03 FILLER PIC X(6) VALUE SPACE.
- 118800 03 FILLER PIC X(7) VALUE " 20-23 ".
- 118900 03 FILLER PIC X(7) VALUE SPACE.
- 119000 03 FILLER PIC X(7) VALUE " 24-30 ".
- 119100 03 FILLER PIC X(4) VALUE SPACE.
- 119200 03 FILLER PIC X(8) VALUE " 31-34 ".
- 119300 03 FILLER PIC X(4) VALUE SPACE.
- 119400 03 FILLER PIC X(8) VALUE " 35-38 ".
- 119500 03 FILLER PIC X(4) VALUE SPACE.
- 119600 03 FILLER PIC X(8) VALUE " 39-42 ".
- 119700 03 FILLER PIC X(4) VALUE SPACE.
- 119800 03 FILLER PIC X(8) VALUE " 43-46 ".
- 119900 03 FILLER PIC X(4) VALUE SPACE.
- 120000 03 FILLER PIC X(8) VALUE " 47-50 ".
- 120100 03 FILLER PIC X(4) VALUE SPACE.
- 120200 03 FILLER PIC X(8) VALUE " 51-54 ".
- 120300 03 FILLER PIC X(4) VALUE SPACE.
- 120400 03 FILLER PIC X(8) VALUE " 55-58 ".
- 120500 03 FILLER PIC X(4) VALUE SPACE.
- 120600 03 FILLER PIC X(8) VALUE " 59-62 ".
- 120700 03 FILLER PIC X(9) VALUE SPACE.
- 120800 01 VP-HDR-REC6.
- 120900 03 FILLER PIC X(6) VALUE SPACE.
- 121000 03 FILLER PIC X(7) VALUE " XXXX ".
- 121100 03 FILLER PIC X(7) VALUE SPACE.
- 121200 03 FILLER PIC X(7) VALUE "XXXXXXX".
- 121300 03 FILLER PIC X(4) VALUE SPACE.
- 121400 03 FILLER PIC X(8) VALUE " XX XX ".
- 121500 03 FILLER PIC X(4) VALUE SPACE.
- 121600 03 FILLER PIC X(8) VALUE " XX XX ".
- 121700 03 FILLER PIC X(4) VALUE SPACE.
- 121800 03 FILLER PIC X(8) VALUE " XX XX ".
- 121900 03 FILLER PIC X(4) VALUE SPACE.
- 122000 03 FILLER PIC X(8) VALUE " XX XX ".
- 122100 03 FILLER PIC X(4) VALUE SPACE.
- 122200 03 FILLER PIC X(8) VALUE " XX XX ".
- 122300 03 FILLER PIC X(4) VALUE SPACE.
- 122400 03 FILLER PIC X(8) VALUE " XX XX ".
- 122500 03 FILLER PIC X(4) VALUE SPACE.
- 122600 03 FILLER PIC X(8) VALUE " XX XX ".
- 122700 03 FILLER PIC X(4) VALUE SPACE.
- 122800 03 FILLER PIC X(8) VALUE " XX XX ".
- 122900 03 FILLER PIC X(9) VALUE SPACE.
- 123000***********************************************************
- 123100 01 MSG-1-V6P.
- 123200 03 FILLER PIC X(24) VALUE SPACE.
- 123300 03 FILLER PIC X(26) VALUE "IF ERROR CORRECTION IS IN ".
- 123400 03 FILLER PIC X(26) VALUE "COMMON DATA (1-12), KEY AL".
- 123500 03 FILLER PIC X(26) VALUE "L RECORDS WITH SAME COMMON".
- 123600 03 FILLER PIC X(26) VALUE " DATA. ".
- 123700 03 FILLER PIC XXXX VALUE SPACE.
- 123800 01 MSG-2-V6.
- 123900 03 FILLER PIC X(24) VALUE SPACE.
- 124000 03 FILLER PIC X(26) VALUE "IF ERROR CORRECTION IS IN ".
- 124100 03 FILLER PIC X(26) VALUE "FIELD POSITIONS (24-63), K".
- 124200 03 FILLER PIC X(26) VALUE "EY (1-23) AND RED CORRECTE".
- 124300 03 FILLER PIC X(26) VALUE "D FIELDS. ".
- 124400 03 FILLER PIC XXXX VALUE SPACE.
- 124500 01 MSG-2-VP.
- 124600 03 FILLER PIC X(24) VALUE SPACE.
- 124700 03 FILLER PIC X(26) VALUE "IF ERROR CORRECTION IS IN ".
- 124800 03 FILLER PIC X(26) VALUE "FIELD POSITIONS (24-62), K".
- 124900 03 FILLER PIC X(26) VALUE "EY (1-23) AND RED CORRECTE".
- 125000 03 FILLER PIC X(26) VALUE "D FIELDS. ".
- 125100 03 FILLER PIC XXXX VALUE SPACE.
- 125200 01 MSG-1-VU.
- 125300 03 FILLER PIC X(24) VALUE SPACE.
- 125400 03 FILLER PIC X(26) VALUE "IF ERROR CORRECTION IS IN ".
- 125500 03 FILLER PIC X(26) VALUE "COMMON DATA (1-12 OR 20), ".
- 125600 03 FILLER PIC X(26) VALUE "KEY ALL RECORDS WITH SAME ".
- 125700 03 FILLER PIC X(26) VALUE "COMMON DATA. ".
- 125800 03 FILLER PIC XXXX VALUE SPACE.
- 125900 01 MSG-2-VU.
- 126000 03 FILLER PIC X(24) VALUE SPACE.
- 126100 03 FILLER PIC X(26) VALUE "IF ERROR CORRECTION IS IN ".
- 126200 03 FILLER PIC X(26) VALUE "FIELD POSITIONS (25-58), K".
- 126300 03 FILLER PIC X(26) VALUE "EY (1-24) AND RED CORRECTE".
- 126400 03 FILLER PIC X(26) VALUE "D FIELDS. ".
- 126500 03 FILLER PIC XXXX VALUE SPACE.
- 126600 01 MSG-1-VF.
- 126700 03 FILLER PIC X(24) VALUE SPACE.
- 126800 03 FILLER PIC X(26) VALUE "IF ERROR CORRECTION IS IN ".
- 126900 03 FILLER PIC X(26) VALUE "COMMON DATA (1-8), KEY AL".
- 127000 03 FILLER PIC X(26) VALUE "L RECORDS WITH SAME COMMON".
- 127100 03 FILLER PIC X(26) VALUE " DATA. ".
- 127200 03 FILLER PIC XXXX VALUE SPACE.
- 127300 01 MSG-2-VF.
- 127400 03 FILLER PIC X(24) VALUE SPACE.
- 127500 03 FILLER PIC X(26) VALUE "IF ERROR CORRECTION IS IN ".
- 127600 03 FILLER PIC X(26) VALUE "FIELD POSITIONS (24-30), K".
- 127700 03 FILLER PIC X(26) VALUE "EY (1-23) AND RED CORRECTE".
- 127800 03 FILLER PIC X(26) VALUE "D FIELDS. ".
- 127900 03 FILLER PIC XXXX VALUE SPACE.
- 128000***********************************************************
- 128100***********************************************************
- 128200 01 AST-HLD.
- 128300 03 ST-HLD-AST PIC XX.
- 128400 03 DIST-HLD-AST PIC XX.
- 128500 03 RA-HLD-AST PIC XX.
- 128600 03 PLU-HLD-AST PIC XX.
- 128700 03 ACTN-HLD-AST PIC XX.
- 128800 01 LAST-HLD.
- 128900 03 LAST-PRINT.
- 129000 05 REC-TYP-LP PIC XXXX.
- 129100 05 SDRP-LP.
- 129200 07 SDR-LP.
- 129300 09 SD-LP.
- 129400 11 ST-LP PIC XX.
- 129500 11 DIST-LP PIC XX.
- 129600 09 RA-LP PIC XX.
- 129700 07 PLU-LP PIC XX.
- 129800 COPY DBSTATUS OF TPCOBOLIB.
- 129900 01 CNTL-HLD.
- 130000 03 CUR-PRINT.
- 130100 05 REC-TYP-HLD PIC XXXX.
- 130200 05 SDRP-HLD.
- 130300 07 SDR-HLD.
- 130400 09 SD-HLD.
- 130500 11 ST-HLD PIC XX.
- 130600 11 DIST-HLD PIC XX.
- 130700 09 RA-HLD PIC XX.
- 130800 07 PLU-HLD PIC XX.
- 130900 03 DATE-HLD PIC X(6).
- 131000 03 ACTN-HLD PIC X.
- 131100 03 DIET-HLD PIC X.
- 131200 01 HLD-NAMES.
- 131300 03 FUNC-HLD.
- 131400 05 ST-NM-HLD PIC X(10).
- 131500 05 FILLER PIC X(14).
- 131600 03 EXPL-HLD.
- 131700 05 DIST-NM-HLD PIC X(11).
- 131800 05 FILLER PIC X.
- 131900 05 RA-NM-HLD PIC X(12).
- 132000 05 FILLER PIC X.
- 132100 05 PU-NM-HLD PIC X(15).
- 132200 05 FILLER PIC X.
- 132300 01 HOLD-AREA.
- 132400 03 CODE-DEC-H.
- 132500 05 FILLER PIC XXXX.
- 132600 05 PLANT-CD-H PIC X(7).
- 132700 05 FILLER PIC X(24).
- 132800 05 PLANT-TYP-H PIC X.
- 132900 03 DE-CD-NAM-8823-DEC-H.
- 133000 05 DIST-NAM-H PIC X(15).
- 133100 05 FILLER PIC X(9).
- 133200 03 HLD-PLANT-CD PIC X(7).
- 133300 03 HLD-PLANT-TYP PIC X.
- 133400 03 HLD-ANML-CD PIC XX.
- 133500 03 PLANT-CD-PREV PIC X(7) VALUE SPACE.
- 133600 03 PLANT-TYP-PREV PIC X VALUE SPACE.
- 133700 03 PLANT-CD-FLG-PREV PIC 9 VALUE ZERO.
- 133800 03 PLANT-TYP-FLG-PREV PIC 9 VALUE ZERO.
- 133900 03 DAT-H.
- 134000 05 YER-H PIC XX.
- 134100 05 MON-H PIC 99.
- 134200 05 DAY-H PIC XX.
- 134300 03 DATA-DATE-VP-HLD.
- 134400 05 DATA-YER-VP-HLD PIC XX.
- 134500 05 DATA-MON-VP-HLD PIC XX.
- 134600 05 DATA-DAY-VP-HLD PIC XX.
- 134700 03 D-DATE-CHK.
- 134800 05 D-YER-CHK PIC XX.
- 134900 05 D-MON-CHK PIC XX.
- 135000 05 D-DAY-CHK PIC XX.
- 135100 03 JDAY-H PIC 9(5).
- 135200 03 JDAY-P0-H PIC 9(5).
- 135300 03 J9-H REDEFINES JDAY-P0-H.
- 135400 05 1ST-2C-JDAY-P0-H PIC 99.
- 135500 05 LST-3C-JDAY-P0-H PIC 999.
- 135600 03 CNTS-IGB-V6.
- 135700 05 V6-I PIC 9(5) VALUE ZERO.
- 135800 05 FILLER PIC XX VALUE SPACE.
- 135900 05 V6-G PIC 9(5) VALUE ZERO.
- 136000 05 FILLER PIC XX VALUE SPACE.
- 136100 05 V6-B PIC 9(5) VALUE ZERO.
- 136200 05 FILLER PIC XX VALUE SPACE.
- 136300 03 CNTS-IGB-VP.
- 136400 05 VP-I PIC 9(5) VALUE ZERO.
- 136500 05 FILLER PIC XX VALUE SPACE.
- 136600 05 VP-G PIC 9(5) VALUE ZERO.
- 136700 05 FILLER PIC XX VALUE SPACE.
- 136800 05 VP-B PIC 9(5) VALUE ZERO.
- 136900 05 FILLER PIC XX VALUE SPACE.
- 137000 03 CNTS-IGB-VF.
- 137100 05 VF-I PIC 9(5) VALUE ZERO.
- 137200 05 FILLER PIC XX VALUE SPACE.
- 137300 05 VF-G PIC 9(5) VALUE ZERO.
- 137400 05 FILLER PIC XX VALUE SPACE.
- 137500 05 VF-B PIC 9(5) VALUE ZERO.
- 137600 05 FILLER PIC XX VALUE SPACE.
- 137700 03 CNTS-IGB-VU.
- 137800 05 VU-I PIC 9(5) VALUE ZERO.
- 137900 05 FILLER PIC XX VALUE SPACE.
- 138000 05 VU-G PIC 9(5) VALUE ZERO.
- 138100 05 FILLER PIC XX VALUE SPACE.
- 138200 05 VU-B PIC 9(5) VALUE ZERO.
- 138300 05 FILLER PIC XX VALUE SPACE.
- 138400 01 LTRL-AREA.
- 138500 03 10ASTRKS-L VALUE ALL "*".
- 138600 05 09ASTRKS-L.
- 138700 07 07ASTRKS-L.
- 138800 09 06ASTRKS-L.
- 138900 11 05ASTRKS-L.
- 139000 13 04ASTRKS-L.
- 139100 15 03ASTRKS-L.
- 139200 17 02ASTRKS-L.
- 139300 19 01ASTRKS-L PIC X.
- 139400 19 FILLER PIC X.
- 139500 17 FILLER PIC X.
- 139600 15 FILLER PIC X.
- 139700 13 FILLER PIC X.
- 139800 11 FILLER PIC X.
- 139900 09 FILLER PIC X.
- 140000 07 FILLER PIC XX.
- 140100 05 FILLER PIC X.
- 140200 01 TABL-AREA.
- 140300 03 MON-V PIC X(36) VALUE "JANFEBMARAPRMAYJUNJULAUGSEPOCT
- 140400- "NOVDEC".
- 140500 03 MON-T REDEFINES MON-V PIC XXX OCCURS 12 TIMES.
- 140600 01 P-SPACE PIC X(132) VALUE SPACE.
- 140700 PROCEDURE DIVISION.
- 140800 000-BEGIN.
- 140900 ACCEPT DAT-H FROM DATE. ACCEPT JDAY-H FROM DAY.
- 141000 MOVE DAY-H TO HDR-DD. MOVE MON-T (MON-H) TO HDR-MMM.
- 141100 MOVE YER-H TO HDR-YR.
- 141200 MOVE SPACE TO LAST-HLD.
- 141300 READY DIC-DE.
- 141400 OPEN OUTPUT FILE-P1.
- 141500 IF TEST-SW = 0
- 141600 OPEN INPUT FILE-D1
- 141700 OPEN OUTPUT FILE-D2.
- 141800 100-READ.
- 141900 IF TEST-SW = 1
- 142000 GO TO 105-TEST.
- 142100 READ FILE-D1 AT END
- 142200 DISPLAY " IN GOOD BAD"
- 142300 DISPLAY "V6 " CNTS-IGB-V6
- 142400 DISPLAY "VP" CNTS-IGB-VP
- 142500 DISPLAY "VU" CNTS-IGB-VU
- 142600 DISPLAY "VF" CNTS-IGB-VF
- 142700 CLOSE FILE-P1
- 142800 CLOSE FILE-D1 FILE-D2
- 142900 FINISH DIC-DE STOP RUN.
- 143000 MOVE FDR-D1 TO FDR-D1-WK.
- 143100 GO TO 200-PROC.
- 143200 105-TEST.
- 143300 ADD 1 TO REC-SUB.
- 143400 MOVE REC-TB (REC-SUB) TO FDR-D1-WK.
- 143500 IF RT-RT (REC-SUB) = "END "
- 143600 DISPLAY " IN GOOD BAD"
- 143700 DISPLAY "V6" CNTS-IGB-V6
- 143800 DISPLAY "VP" CNTS-IGB-VP
- 143900 DISPLAY "VU" CNTS-IGB-VU
- 144000 DISPLAY "VF" CNTS-IGB-VF
- 144100 CLOSE FILE-P1
- 144200 FINISH DIC-DE STOP RUN.
- 144300 200-PROC.
- 144400 MOVE ZERO TO KEY-FLG ERR-FLG AST-FLG.
- 144500 IF REC-TYP-D1 = REC-TYP-HLD NEXT SENTENCE ELSE
- 144600 IF REC-TYP-D1 = "VP1D"
- 144700 MOVE "VP EDIT ERROR LISTING" TO RMK-HDR-2 ELSE
- 144800 IF REC-TYP-D1 = "VU1D"
- 144900 MOVE "VU EDIT ERROR LISTING" TO RMK-HDR-2 ELSE
- 145000 IF REC-TYP-D1 = "V61D"
- 145100 MOVE "V6 EDIT ERROR LISTING" TO RMK-HDR-2 ELSE
- 145200 IF REC-TYP-D1 = "VF1D"
- 145300 MOVE "VF EDIT ERROR LISTING" TO RMK-HDR-2 ELSE
- 145400 NEXT SENTENCE.
- 145500 MOVE CNTL-D1 TO CNTL-HLD.
- 145600 IF ACTN-D1 = "A" OR "C" OR "D"
- 145700 NEXT SENTENCE ELSE
- 145800 MOVE "*" TO ACTN-HLD-AST
- 145900 MOVE 1 TO KEY-FLG.
- 146000 IF REC-TYP-HLD = "V61D"
- 146100 ADD 1 TO V6-I
- 146200 MOVE FDR-D1-WK TO REC-V6-X
- 146300 PERFORM 300-EDIT-V6 THRU 320-EDIT-V6-EXIT.
- 146400 IF REC-TYP-HLD = "VU1D"
- 146500 ADD 1 TO VU-I
- 146600 MOVE FDR-D1-WK TO REC-VU-X
- 146700 PERFORM 500-EDIT-VU THRU 540-EDIT-VU-EXIT.
- 146800 IF REC-TYP-HLD = "VF1D"
- 146900 ADD 1 TO VF-I
- 147000 MOVE FDR-D1-WK TO REC-VF-X
- 147100 PERFORM 600-EDIT-VF THRU 640-EDIT-VF-EXIT.
- 147200 IF REC-TYP-HLD = "VP1D"
- 147300 ADD 1 TO VP-I
- 147400 MOVE FDR-D1-WK TO REC-VP-X
- 147500 PERFORM 400-EDIT-VP THRU 430-EDIT-VP-EXIT.
- 147600 IF REC-TYP-HLD = "VU1D" OR "VP1D" OR "VF1D" OR "V61D"
- 147700 GO TO 100-READ.
- 147800 DISPLAY "BAD RECORD".
- 147900 DISPLAY FDR-D1-WK.
- 148000 GO TO 100-READ.
- 148100 210-DB-SDRP.
- 148200 MOVE CNTL-D1 TO CNTL-HLD.
- 148300 MOVE ZERO TO KEY-FLG.
- 148400 IF ST-D1 = ST-LP
- 148500 GO TO 220-CK-DIST.
- 148600 MOVE 99 TO LIN-CNT.
- 148700 MOVE ST-HLD TO DE-CD-8822-DEC.
- 148800 MOVE 0003 TO DE-NO-8801-DEC.
- 148900 FIND ANY CODE-DEC.
- 149000 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 149100 IF OK
- 149200 GET CODE-DEC
- 149300 MOVE DE-CD-NAM-8823-DEC TO FUNC-HLD
- 149400 MOVE ST-NM-HLD TO HDR-ST-NM
- 149500 ELSE MOVE "UNKNOWN" TO HDR-ST-NM
- 149600 HDR-DIST-NM
- 149700 MOVE 1 TO KEY-FLG
- 149800 MOVE 02ASTRKS-L TO ST-HLD-AST
- 149900 GO TO 250-EXIT.
- 150000 220-CK-DIST.
- 150100 IF SD-D1 = SD-LP
- 150200 GO TO 230-CK-RA.
- 150300 MOVE SD-HLD TO DE-CD-8822-DEC.
- 150400 MOVE 0003 TO DE-NO-8801-DEC.
- 150500 FIND ANY CODE-DEC.
- 150600 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 150700 IF OK
- 150800 GET CODE-DEC
- 150900 ELSE MOVE "UNKNOWN" TO HDR-DIST-NM
- 151000 MOVE 1 TO KEY-FLG
- 151100 MOVE 02ASTRKS-L TO DIST-HLD-AST
- 151200 GO TO 250-EXIT.
- 151300 FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
- 151400 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 151500 IF OK
- 151600 GET CODE-EXPL-DECE
- 151700 MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HLD
- 151800 MOVE DIST-NM-HLD TO HDR-DIST-NM
- 151900 ELSE
- 152000 MOVE "UNKNOWN" TO HDR-DIST-NM
- 152100 MOVE 1 TO KEY-FLG
- 152200 MOVE 02ASTRKS-L TO DIST-HLD-AST
- 152300 GO TO 250-EXIT.
- 152400 230-CK-RA.
- 152500 IF SDR-D1 = SDR-LP
- 152600 GO TO 240-CK-PLU.
- 152700 IF (RA-HLD = "99") AND (PLU-HLD NOT = "99")
- 152800 MOVE 1 TO KEY-FLG
- 152900 MOVE 02ASTRKS-L TO RA-HLD-AST
- 153000 GO TO 250-EXIT.
- 153100 IF RA-HLD = "99"
- 153200 GO TO 250-EXIT.
- 153300 MOVE SDR-HLD TO DE-CD-8822-DEC.
- 153400 MOVE 0003 TO DE-NO-8801-DEC.
- 153500 FIND ANY CODE-DEC.
- 153600 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 153700 IF OK
- 153800 GO TO 240-CK-PLU.
- 153900 MOVE 1 TO KEY-FLG.
- 154000 MOVE 02ASTRKS-L TO RA-HLD-AST
- 154100 GO TO 250-EXIT.
- 154200 240-CK-PLU.
- 154300 IF SDRP-D1 = SDRP-LP
- 154400 GO TO 250-EXIT.
- 154500 IF PLU-HLD = "99"
- 154600 GO TO 250-EXIT.
- 154700 MOVE SDRP-HLD TO DE-CD-8822-DEC.
- 154800 MOVE 0003 TO DE-NO-8801-DEC.
- 154900 FIND ANY CODE-DEC.
- 155000 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 155100 IF OK
- 155200 GO TO 250-EXIT.
- 155300 MOVE 1 TO KEY-FLG.
- 155400 MOVE 02ASTRKS-L TO PLU-HLD-AST.
- 155500 GO TO 250-EXIT.
- 155600 250-EXIT.
- 155700 EXIT.
- 155800 260-DB-PLANT.
- 155900 IF HLD-PLANT-CD = PLANT-CD-PREV
- 156000 MOVE PLANT-TYP-FLG-PREV TO PLANT-TYP-FLG
- 156100 MOVE PLANT-CD-FLG-PREV TO PLANT-CD-FLG
- 156200 GO TO 260-EXIT.
- 156300 MOVE HLD-PLANT-CD TO PLANT-CD-PREV.
- 156400 MOVE ZERO TO PLANT-CD-FLG PLANT-CD-FLG-PREV.
- 156500 IF HLD-PLANT-CD = "POTEN2 " OR "HYMEN "
- 156600 MOVE "F" TO PLANT-TYP-H PLANT-TYP-PREV
- 156700 MOVE 2 TO PLANT-TYP-FLG PLANT-TYP-FLG-PREV
- 156800 GO TO 260-EXIT.
- 156900 MOVE HLD-PLANT-CD TO DE-CD-8822-DEC.
- 157000 MOVE 2646 TO DE-NO-8801-DEC.
- 157100 FIND ANY CODE-DEC.
- 157200 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 157300 IF NOT OK
- 157400 MOVE 1 TO PLANT-CD-FLG PLANT-CD-FLG-PREV
- 157500 GO TO 260-EXIT.
- 157600 GET CODE-DEC.
- 157700 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 157800 IF NOT OK
- 157900 MOVE 1 TO PLANT-CD-FLG PLANT-CD-FLG-PREV
- 158000 GO TO 260-EXIT.
- 158100 MOVE CODE-DEC TO CODE-DEC-H.
- 158200 IF PLANT-TYP-H NOT = "F" AND "G" AND "T" AND "S"
- 158300 MOVE 1 TO PLANT-CD-FLG PLANT-CD-FLG-PREV
- 158400 MOVE 0 TO PLANT-TYP-FLG PLANT-TYP-FLG-PREV
- 158500 GO TO 260-EXIT.
- 158600 IF PLANT-TYP-H = "G" MOVE 1 TO PLANT-TYP-FLG
- 158700 PLANT-TYP-FLG-PREV
- 158800 ELSE MOVE 2 TO PLANT-TYP-FLG PLANT-TYP-FLG-PREV.
- 158900 260-EXIT.
- 159000 EXIT.
- 159100 280-DB-ANML.
- 159200 IF HLD-ANML-CD =
- 159300 "CA" OR "DM" OR "ER" OR "SH" OR "AN" OR "HO"
- 159400 GO TO 290-EXIT.
- 159500 MOVE HLD-ANML-CD TO DE-CD-8822-DEC.
- 159600 MOVE 3929 TO DE-NO-8801-DEC.
- 159700 FIND ANY CODE-DEC.
- 159800 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 159900 IF NOT OK
- 160000 MOVE 1 TO ANML-CD-FLG
- 160100 GO TO 290-EXIT.
- 160200 GET CODE-DEC.
- 160300 IF NOT OK
- 160400 MOVE 1 TO ANML-CD-FLG
- 160500 GO TO 290-EXIT.
- 160600 290-EXIT.
- 160700 EXIT.
- 160800 300-EDIT-V6.
- 160900 MOVE SPACE TO AST-HLD REC-1-V6P-AST REC-2-V6-AST
- 161000 EXAMINE GRP-1-V6-X REPLACING ALL SPACES BY ZEROS.
- 161100 EXAMINE ADW-PCT-3546-V6-X REPLACING ALL SPACES BY ZEROS.
- 161200 EXAMINE PHNO-STG-CD-3712-V6-X REPLACING ALL SPACES BY ZEROS.
- 161300 PERFORM 210-DB-SDRP THRU 250-EXIT.
- 161400 MOVE ST-HLD-AST TO ST-V6P-AST.
- 161500 MOVE DIST-HLD-AST TO DIST-V6P-AST.
- 161600 MOVE RA-HLD-AST TO RA-V6P-AST.
- 161700 MOVE PLU-HLD-AST TO PLU-V6P-AST.
- 161800 MOVE PLANT-CD-2646-V6-X TO HLD-PLANT-CD.
- 161900 PERFORM 260-DB-PLANT THRU 260-EXIT.
- 162000 MOVE PLANT-TYP-H TO PLANT-TYP-V6-X.
- 162100 IF PLANT-CD-FLG = 1
- 162200 MOVE 1 TO ERR-FLG
- 162300 MOVE 07ASTRKS-L TO PLANT-CD-V6-AST.
- 162400 IF PHNO-STG-CD-3712-V6-X > 0 AND < 9 NEXT SENTENCE ELSE
- 162500 MOVE 1 TO ERR-FLG
- 162600 MOVE 01ASTRKS-L TO PHNO-V6-AST.
- 162700 IF GRAMS-GRN-WGT-3941-V6-X = SPACE
- 162800 NEXT SENTENCE ELSE
- 162900 IF (GRAMS-GRN-WGT-3941-V6-X NOT GREATER THAN ZERO) OR
- 163000 (GRAMS-GRN-WGT-3941-V6-X NOT NUMERIC)
- 163100 MOVE ALL "*" TO GRN-WGT-V6-AST
- 163200 MOVE 1 TO ERR-FLG.
- 163300 IF GRAMS-DRY-WGT-3942-V6-X = SPACE
- 163400 NEXT SENTENCE ELSE
- 163500 IF (GRAMS-DRY-WGT-3942-V6-X NOT GREATER THAN ZERO) OR
- 163600 (GRAMS-DRY-WGT-3942-V6-X NOT NUMERIC)
- 163700 MOVE ALL "*" TO DW-V6-AST
- 163800 MOVE 1 TO ERR-FLG.
- 163900 IF PLANT-TYP-FLG = 2
- 164000 MOVE ZERO TO BASAL-DIMS-MIN-V6-X
- 164100 MOVE ZERO TO BASAL-DIMS-MAX-V6-X.
- 164200 IF PLANT-TYP-FLG = 1
- 164300 MOVE ZERO TO CROWN-DIMS-MIN-V6-X
- 164400 MOVE ZERO TO CROWN-DIMS-MAX-V6-X.
- 164500 IF (BASAL-DIMS-MIN-V6-X NOT NUMERIC) OR
- 164600 ((PLANT-TYP-FLG = 2) AND
- 164700 (BASAL-DIMS-MIN-V6-X > ZERO))
- 164800 MOVE 1 TO ERR-FLG
- 164900 MOVE ALL "*" TO MIN-BAD-V6-AST.
- 165000 IF (BASAL-DIMS-MAX-V6-X NOT NUMERIC) OR
- 165100 ((PLANT-TYP-FLG = 2) AND
- 165200 (BASAL-DIMS-MAX-V6-X > ZERO))
- 165300 MOVE 1 TO ERR-FLG
- 165400 MOVE ALL "*" TO MAX-BAD-V6-AST.
- 165500 IF (CROWN-DIMS-MIN-V6-X NOT NUMERIC) OR
- 165600 ((PLANT-TYP-FLG = 1) AND
- 165700 (CROWN-DIMS-MIN-V6-X > ZERO))
- 165800 MOVE 1 TO ERR-FLG
- 165900 MOVE ALL "*" TO MIN-CRND-V6-AST.
- 166000 IF (CROWN-DIMS-MAX-V6-X NOT NUMERIC) OR
- 166100 ((PLANT-TYP-FLG = 1) AND
- 166200 (CROWN-DIMS-MAX-V6-X > ZERO))
- 166300 MOVE 1 TO ERR-FLG
- 166400 MOVE ALL "*" TO MAX-CRND-V6-AST.
- 166500 IF HGT-AVG-V6-X = SPACE
- 166600 NEXT SENTENCE ELSE
- 166700 IF HGT-AVG-V6-X NOT NUMERIC
- 166800 MOVE ALL "*" TO HGT-V6-AST
- 166900 MOVE 1 TO ERR-FLG.
- 167000 IF AVG-LDR-V6-X = SPACE
- 167100 NEXT SENTENCE ELSE
- 167200 IF AVG-LDR-V6-X NOT NUMERIC
- 167300 MOVE ALL "*" TO AVG-LDR-V6-AST
- 167400 MOVE 1 TO ERR-FLG.
- 167500 310-PRINT.
- 167600 MOVE ERR-FLG TO AST-FLG.
- 167700 IF KEY-FLG = 1 MOVE 1 TO ERR-FLG.
- 167800 MOVE REC-V6-X TO REC-V6-Z.
- 167900 IF ERR-FLG = ZERO
- 168000 WRITE FDR-D2 FROM REC-V6-Z
- 168100 ADD 1 TO V6-G
- 168200 GO TO 320-EDIT-V6-EXIT
- 168300 ELSE
- 168400 ADD 1 TO V6-B.
- 168500 IF CUR-PRINT NOT = LAST-PRINT
- 168600 MOVE MSG-1-V6P TO HDR-3
- 168700 MOVE MSG-2-V6 TO HDR-4
- 168800 PERFORM 800-OFLO THRU 800-EXIT
- 168900 PERFORM 720-PRINT-V6-1 THRU 720-EXIT-1.
- 169000 IF LIN-CNT > 51
- 169100 PERFORM 800-OFLO THRU 800-EXIT.
- 169200 IF HEAD-SW = 1
- 169300 MOVE ZERO TO HEAD-SW
- 169400 PERFORM 720-PRINT-V6-2 THRU 720-EXIT
- 169500 ELSE
- 169600 PERFORM 720-PRINT-V6-3 THRU 720-EXIT.
- 169700 320-EDIT-V6-EXIT.
- 169800 EXIT.
- 169900 400-EDIT-VP.
- 170000 MOVE SPACE TO REC-2-VF-P.
- 170100 MOVE SPACE TO AST-HLD REC-1-V6P-AST REC-2-VP-AST
- 170200 EXAMINE PHNO-GP-VP-X REPLACING ALL SPACES BY ZEROS.
- 170300 PERFORM 210-DB-SDRP THRU 250-EXIT.
- 170400 MOVE ST-HLD-AST TO ST-V6P-AST.
- 170500 MOVE DIST-HLD-AST TO DIST-V6P-AST.
- 170600 MOVE RA-HLD-AST TO RA-V6P-AST.
- 170700 MOVE PLU-HLD-AST TO PLU-V6P-AST.
- 170800 MOVE PLANT-CD-2646-VP-X TO HLD-PLANT-CD.
- 170900 PERFORM 260-DB-PLANT THRU 260-EXIT.
- 171000 MOVE PLANT-TYP-H TO PLANT-TYP-3590-VP-X.
- 171100 IF PLANT-CD-FLG = 1
- 171200 MOVE 1 TO ERR-FLG
- 171300 MOVE 07ASTRKS-L TO PLANT-CD-VP-AST.
- 171400 MOVE ZERO TO SUB PHNO-CNT.
- 171500 410-LP.
- 171600 ADD 1 TO SUB.
- 171700 IF (SUB = 9) AND (PHNO-CNT = 8)
- 171800 MOVE 05ASTRKS-L TO PHNO-PCT-VP-AST (1)
- 171900 MOVE 1 TO ERR-FLG.
- 172000 IF SUB = 9 GO TO 420-PRINT.
- 172100 IF (PHNO-ADJ-VP-X (SUB) = ZERO)
- 172200 ADD 1 TO PHNO-CNT
- 172300 GO TO 410-LP.
- 172400 IF (PHNO-ADJ-VP-X (SUB) NOT NUMERIC)
- 172500 MOVE 05ASTRKS-L TO PHNO-PCT-VP-AST (SUB)
- 172600 MOVE 1 TO ERR-FLG.
- 172700 GO TO 410-LP.
- 172800 420-PRINT.
- 172900 MOVE ERR-FLG TO AST-FLG.
- 173000 IF KEY-FLG = 1 MOVE 1 TO ERR-FLG.
- 173100 MOVE REC-VP-X TO REC-VP-Z.
- 173200 IF ERR-FLG = ZERO
- 173300 WRITE FDR-D2 FROM REC-VP-Z
- 173400 ADD 1 TO VP-G
- 173500 GO TO 430-EDIT-VP-EXIT
- 173600 ELSE
- 173700 ADD 1 TO VP-B.
- 173800 IF CUR-PRINT NOT = LAST-PRINT
- 173900 MOVE MSG-1-V6P TO HDR-3
- 174000 MOVE MSG-2-VP TO HDR-4
- 174100 PERFORM 800-OFLO THRU 800-EXIT
- 174200 PERFORM 710-PRINT-VP-1 THRU 710-EXIT-1.
- 174300 IF LIN-CNT > 51
- 174400 PERFORM 800-OFLO THRU 800-EXIT.
- 174500 IF HEAD-SW = 1
- 174600 MOVE ZERO TO HEAD-SW
- 174700 PERFORM 710-PRINT-VP-2 THRU 710-EXIT
- 174800 ELSE
- 174900 PERFORM 710-PRINT-VP-3 THRU 710-EXIT.
- 175000 430-EDIT-VP-EXIT.
- 175100 EXIT.
- 175200 500-EDIT-VU.
- 175300 MOVE SPACE TO AST-HLD REC-1-VU-AST REC-2-VU-AST
- 175400 EXAMINE AUF-3928-VU-X-RD REPLACING ALL SPACES BY ZEROS.
- 175500 EXAMINE PUF-3511-VU-X-RD REPLACING ALL SPACES BY ZEROS.
- 175600 PERFORM 210-DB-SDRP THRU 250-EXIT.
- 175700 MOVE ST-HLD-AST TO ST-VU-AST.
- 175800 MOVE DIST-HLD-AST TO DIST-VU-AST.
- 175900 MOVE RA-HLD-AST TO RA-VU-AST.
- 176000 MOVE PLU-HLD-AST TO PLU-VU-AST.
- 176100 MOVE PLANT-CD-2646-VU-X TO HLD-PLANT-CD.
- 176200 PERFORM 260-DB-PLANT THRU 260-EXIT.
- 176300 MOVE PLANT-TYP-H TO PLANT-TYP-3590-VU-X.
- 176400 IF PLANT-CD-FLG = 1
- 176500 MOVE 1 TO ERR-FLG
- 176600 MOVE 07ASTRKS-L TO PLANT-CD-VU-AST.
- 176700 IF DIET-USE-TYP-3917-VU-X = "D" OR "P"
- 176800 NEXT SENTENCE ELSE
- 176900 MOVE 01ASTRKS-L TO PUFDT-VU-AST
- 177000 MOVE 1 TO KEY-FLG.
- 177100 IF ANML-GRZG-CD-3929-VU-X =
- 177200 "CA" OR "DM" OR "ER" OR "SH" OR "AN" OR "HO"
- 177300 MOVE ZERO TO SUB AUF-CNT
- 177400 GO TO 510-LP.
- 177500* MOVE ANML-GRZG-CD-3929-VU-X TO DE-CD-8822-DEC.
- 177600* MOVE 3929 TO DE-NO-8801-DEC. FIND ANY CODE-DEC.
- 177700* MOVE DB-STATUS TO DATA-BASE-STATUS.
- 177800* IF NOT OK
- 177900* MOVE 02ASTRKS-L TO ANML-SP-VU-AST
- 178000* MOVE 1 TO ERR-FLG.
- 178100 MOVE ZERO TO SUB AUF-CNT.
- 178200 510-LP.
- 178300 ADD 1 TO SUB.
- 178400* IF (SUB = 6) AND (AUF-CNT = 5)
- 178500* MOVE 03ASTRKS-L TO PLNT-SPG-VU-AST
- 178600* MOVE 1 TO ERR-FLG.
- 178700 IF SUB = 6
- 178800 MOVE ZERO TO SUB PUF-CNT
- 178900 GO TO 520-LP.
- 179000 IF (AUF-3928-VU-X (SUB) = ZERO)
- 179100 ADD 1 TO AUF-CNT
- 179200 GO TO 510-LP.
- 179300 IF (AUF-3928-VU-X (SUB) NOT NUMERIC)
- 179400 MOVE 03ASTRKS-L TO AUF-PCT-VU-AST (SUB)
- 179500 MOVE 1 TO ERR-FLG.
- 179600 GO TO 510-LP.
- 179700 520-LP.
- 179800 ADD 1 TO SUB.
- 179900* IF (SUB = 6) AND (PUF-CNT = 5)
- 180000* MOVE 02ASTRKS-L TO ANML-SPG-VU-AST
- 180100* MOVE 1 TO ERR-FLG.
- 180200 IF SUB = 6 GO TO 530-PRINT.
- 180300 IF (PUF-3511-VU-X (SUB) = ZERO)
- 180400 ADD 1 TO PUF-CNT
- 180500 GO TO 520-LP.
- 180600 IF (PUF-3511-VU-X (SUB) NOT NUMERIC)
- 180700 MOVE 02ASTRKS-L TO PUF-VU-AST (SUB)
- 180800 MOVE 1 TO ERR-FLG.
- 180900 GO TO 520-LP.
- 181000 530-PRINT.
- 181100 MOVE ERR-FLG TO AST-FLG.
- 181200 IF KEY-FLG = 1 MOVE 1 TO ERR-FLG.
- 181300 MOVE REC-VU-X TO REC-VU-Z.
- 181400 IF ERR-FLG = ZERO
- 181500 WRITE FDR-D2 FROM REC-VU-Z
- 181600 ADD 1 TO VU-G
- 181700 GO TO 540-EDIT-VU-EXIT
- 181800 ELSE
- 181900 ADD 1 TO VU-B.
- 182000 IF CUR-PRINT NOT = LAST-PRINT
- 182100 MOVE MSG-1-VU TO HDR-3
- 182200 MOVE MSG-2-VU TO HDR-4
- 182300 PERFORM 800-OFLO THRU 800-EXIT
- 182400 PERFORM 730-PRINT-VU-1 THRU 730-EXIT-1.
- 182500 IF LIN-CNT > 51
- 182600 PERFORM 800-OFLO THRU 800-EXIT.
- 182700 IF HEAD-SW = 1
- 182800 MOVE ZERO TO HEAD-SW
- 182900 PERFORM 730-PRINT-VU-2 THRU 730-EXIT
- 183000 ELSE
- 183100 PERFORM 730-PRINT-VU-3 THRU 730-EXIT.
- 183200 540-EDIT-VU-EXIT.
- 183300 EXIT.
- 183400 600-EDIT-VF.
- 183500 MOVE SPACE TO AST-HLD REC-1-VF-AST REC-2-VF-AST
- 183600 EXAMINE MON-FORG-RQMT-LBS-3551-VF-X REPLACING ALL SPACES
- 183700 BY ZEROS.
- 183800 PERFORM 210-DB-SDRP THRU 250-EXIT.
- 183900 MOVE ST-HLD-AST TO ST-VF-AST.
- 184000 MOVE DIST-HLD-AST TO DIST-VF-AST.
- 184100 IF ANML-HGT-CLS-CD-3548-VF-X = "1" OR "2" OR "3" OR "4"
- 184200 NEXT SENTENCE ELSE
- 184300 MOVE 01ASTRKS-L TO HT-CLS-AV-VF-AST
- 184400 MOVE 1 TO ERR-FLG.
- 184500 IF (MON-FORG-RQMT-LBS-3551-VF-X NOT NUMERIC)
- 184600 MOVE 04ASTRKS-L TO MON-FORG-VF-AST
- 184700 MOVE 1 TO ERR-FLG.
- 184800 IF ANML-GRZG-CD-3929-VF-X =
- 184900 "CA" OR "DM" OR "ER" OR "SH" OR "AN" OR "HO"
- 185000 GO TO 610-PRINT.
- 185100* MOVE ANML-GRZG-CD-3929-VF-X TO DE-CD-8822-DEC.
- 185200* MOVE 3929 TO DE-NO-8801-DEC. FIND ANY CODE-DEC.
- 185300* MOVE DB-STATUS TO DATA-BASE-STATUS.
- 185400* IF NOT OK
- 185500* MOVE 02ASTRKS-L TO ANML-SP-VF-AST
- 185600* MOVE 1 TO ERR-FLG.
- 185700 610-PRINT.
- 185800 MOVE ERR-FLG TO AST-FLG.
- 185900 IF KEY-FLG = 1 MOVE 1 TO ERR-FLG.
- 186000 MOVE REC-VF-X TO REC-VF-Z.
- 186100 IF ERR-FLG = ZERO
- 186200 WRITE FDR-D2 FROM REC-VF-Z
- 186300 ADD 1 TO VF-G
- 186400 GO TO 640-EDIT-VF-EXIT
- 186500 ELSE
- 186600 ADD 1 TO VF-B.
- 186700 IF CUR-PRINT NOT = LAST-PRINT
- 186800 MOVE MSG-1-VF TO HDR-3
- 186900 MOVE MSG-2-VF TO HDR-4
- 187000 PERFORM 800-OFLO THRU 800-EXIT
- 187100 PERFORM 700-PRINT-VF-1 THRU 700-EXIT-1.
- 187200 IF LIN-CNT > 51
- 187300 PERFORM 800-OFLO THRU 800-EXIT.
- 187400 IF HEAD-SW = 1
- 187500 MOVE ZERO TO HEAD-SW
- 187600 PERFORM 700-PRINT-VF-2 THRU 700-EXIT
- 187700 ELSE
- 187800 PERFORM 700-PRINT-VF-3 THRU 700-EXIT.
- 187900 640-EDIT-VF-EXIT.
- 188000 EXIT.
- 188100 700-PRINT-VF-1.
- 188200 MOVE SPACE TO REC-1-VF-P.
- 188300 MOVE DIC-VF-X TO REC-VF-P.
- 188400 MOVE BLM-ADM-U-0003-ST-VF-X TO ST-VF-P.
- 188500 MOVE BLM-ADM-U-0003-DIST-VF-X TO DIST-VF-P.
- 188600 MOVE DATA-DATE-6618-VF-X TO DATE-VF-P.
- 188700 MOVE ACTN-CD-7350-VF-X TO ACTN-VF-P.
- 188800 WRITE FDR-P1 FROM VF-HDR-REC1 AFTER ADVANCING 2 LINES.
- 188900 WRITE FDR-P1 FROM VF-HDR-REC2 AFTER ADVANCING 1 LINES.
- 189000 WRITE FDR-P1 FROM VF-HDR-REC3 AFTER ADVANCING 1 LINES.
- 189100 WRITE FDR-P1 FROM REC-1-VF-P AFTER ADVANCING 2 LINES.
- 189200 WRITE FDR-P1 FROM REC-1-VF-AST AFTER ADVANCING 1 LINES.
- 189300 ADD 7 TO LIN-CNT.
- 189400 700-EXIT-1.
- 189500 EXIT.
- 189600 700-PRINT-VF-2.
- 189700 WRITE FDR-P1 FROM VF-HDR-REC4 AFTER ADVANCING 2 LINES.
- 189800 WRITE FDR-P1 FROM VF-HDR-REC5 AFTER ADVANCING 1 LINES.
- 189900 WRITE FDR-P1 FROM VF-HDR-REC6 AFTER ADVANCING 1 LINES.
- 190000 ADD 4 TO LIN-CNT.
- 190100 700-PRINT-VF-3.
- 190200 MOVE SPACE TO REC-2-VF-P.
- 190300 MOVE LIN-NUM-3578-VF-X TO LINE-VF-P.
- 190400 MOVE ANML-GRZG-CD-3929-VF-X TO ANML-SP-VF-P.
- 190500 MOVE MON-FORG-RQMT-LBS-3551-VF-X TO MON-FORG-VF-P.
- 190600 MOVE ANML-HGT-CLS-CD-3548-VF-X TO HT-CLS-AV-VF-P.
- 190700 ADD 2 TO LIN-CNT.
- 190800 WRITE FDR-P1 FROM REC-2-VF-P AFTER ADVANCING 2 LINES.
- 190900 IF AST-FLG = 1
- 191000 WRITE FDR-P1 FROM REC-2-VF-AST AFTER ADVANCING 1 LINES
- 191100 ADD 1 TO LIN-CNT.
- 191200 700-EXIT.
- 191300 EXIT.
- 191400 710-PRINT-VP-1.
- 191500 MOVE SPACE TO REC-1-V6P-P.
- 191600 MOVE DIC-VP-X TO REC-V6P-P.
- 191700 MOVE BLM-ADM-U-0003-ST-VP-X TO ST-V6P-P.
- 191800 MOVE BLM-ADM-U-0003-DIST-VP-X TO DIST-V6P-P.
- 191900 MOVE BLM-ADM-U-0003-RA-VP-X TO RA-V6P-P.
- 192000 MOVE BLM-ADM-U-0003-PLU-VP-X TO PLU-V6P-P.
- 192100 MOVE DATA-DATE-6618-VP-X TO DATE-V6P-P.
- 192200 MOVE ACTN-CD-7350-VP-X TO ACTN-V6P-P.
- 192300 WRITE FDR-P1 FROM V6P-HDR-REC1 AFTER ADVANCING 2 LINES.
- 192400 WRITE FDR-P1 FROM V6P-HDR-REC2 AFTER ADVANCING 1 LINES.
- 192500 WRITE FDR-P1 FROM V6P-HDR-REC3 AFTER ADVANCING 1 LINES.
- 192600 WRITE FDR-P1 FROM REC-1-V6P-P AFTER ADVANCING 2 LINES.
- 192700 WRITE FDR-P1 FROM REC-1-V6P-AST AFTER ADVANCING 1 LINES.
- 192800 ADD 7 TO LIN-CNT.
- 192900 710-EXIT-1.
- 193000 EXIT.
- 193100 710-PRINT-VP-2.
- 193200 WRITE FDR-P1 FROM VP-HDR-REC4 AFTER ADVANCING 2 LINES.
- 193300 WRITE FDR-P1 FROM VP-HDR-REC5 AFTER ADVANCING 1 LINES.
- 193400 WRITE FDR-P1 FROM VP-HDR-REC6 AFTER ADVANCING 1 LINES.
- 193500 ADD 4 TO LIN-CNT.
- 193600 710-PRINT-VP-3.
- 193700 MOVE SPACE TO REC-2-VP-P.
- 193800 MOVE LIN-NUM-3578-VP-X TO LINE-VP-P.
- 193900 MOVE PLANT-CD-2646-VP-X TO PLANT-CD-VP-P.
- 194000 IF PHNO-ADJ-VP-X (1) NOT = SPACE AND ZERO
- 194100 MOVE PHNO-ADJ-1-VP-X (1) TO PHNO-PCT-VP-P1 (1)
- 194200 MOVE PHNO-ADJ-2-VP-X (1) TO PHNO-PCT-VP-P3 (1)
- 194300 MOVE "." TO PHNO-PCT-VP-P2 (1).
- 194400 IF PHNO-ADJ-VP-X (2) NOT = SPACE AND ZERO
- 194500 MOVE PHNO-ADJ-1-VP-X (2) TO PHNO-PCT-VP-P1 (2)
- 194600 MOVE PHNO-ADJ-2-VP-X (2) TO PHNO-PCT-VP-P3 (2)
- 194700 MOVE "." TO PHNO-PCT-VP-P2 (2).
- 194800 IF PHNO-ADJ-VP-X (3) NOT = SPACE AND ZERO
- 194900 MOVE PHNO-ADJ-1-VP-X (3) TO PHNO-PCT-VP-P1 (3)
- 195000 MOVE PHNO-ADJ-2-VP-X (3) TO PHNO-PCT-VP-P3 (3)
- 195100 MOVE "." TO PHNO-PCT-VP-P2 (3).
- 195200 IF PHNO-ADJ-VP-X (4) NOT = SPACE AND ZERO
- 195300 MOVE PHNO-ADJ-1-VP-X (4) TO PHNO-PCT-VP-P1 (4)
- 195400 MOVE PHNO-ADJ-2-VP-X (4) TO PHNO-PCT-VP-P3 (4)
- 195500 MOVE "." TO PHNO-PCT-VP-P2 (4).
- 195600 IF PHNO-ADJ-VP-X (5) NOT = SPACE AND ZERO
- 195700 MOVE PHNO-ADJ-1-VP-X (5) TO PHNO-PCT-VP-P1 (5)
- 195800 MOVE PHNO-ADJ-2-VP-X (5) TO PHNO-PCT-VP-P3 (5)
- 195900 MOVE "." TO PHNO-PCT-VP-P2 (5).
- 196000 IF PHNO-ADJ-VP-X (6) NOT = SPACE AND ZERO
- 196100 MOVE PHNO-ADJ-1-VP-X (6) TO PHNO-PCT-VP-P1 (6)
- 196200 MOVE PHNO-ADJ-2-VP-X (6) TO PHNO-PCT-VP-P3 (6)
- 196300 MOVE "." TO PHNO-PCT-VP-P2 (6).
- 196400 IF PHNO-ADJ-VP-X (7) NOT = SPACE AND ZERO
- 196500 MOVE PHNO-ADJ-1-VP-X (7) TO PHNO-PCT-VP-P1 (7)
- 196600 MOVE PHNO-ADJ-2-VP-X (7) TO PHNO-PCT-VP-P3 (7)
- 196700 MOVE "." TO PHNO-PCT-VP-P2 (7).
- 196800 IF PHNO-ADJ-VP-X (8) NOT = SPACE AND ZERO
- 196900 MOVE PHNO-ADJ-1-VP-X (8) TO PHNO-PCT-VP-P1 (8)
- 197000 MOVE PHNO-ADJ-2-VP-X (8) TO PHNO-PCT-VP-P3 (8)
- 197100 MOVE "." TO PHNO-PCT-VP-P2 (8).
- 197200 WRITE FDR-P1 FROM REC-2-VP-P AFTER ADVANCING 2 LINES.
- 197300 ADD 2 TO LIN-CNT.
- 197400 IF AST-FLG = 1
- 197500 WRITE FDR-P1 FROM REC-2-VP-AST AFTER ADVANCING 1 LINES
- 197600 ADD 1 TO LIN-CNT.
- 197700 710-EXIT.
- 197800 EXIT.
- 197900 720-PRINT-V6-1.
- 198000 MOVE SPACE TO REC-1-V6P-P.
- 198100 MOVE DIC-V6-X TO REC-V6P-P.
- 198200 MOVE BLM-ADM-U-0003-ST-V6-X TO ST-V6P-P.
- 198300 MOVE BLM-ADM-U-0003-DIST-V6-X TO DIST-V6P-P.
- 198400 MOVE BLM-ADM-U-0003-RA-V6-X TO RA-V6P-P.
- 198500 MOVE BLM-ADM-U-0003-PLU-V6-X TO PLU-V6P-P.
- 198600 MOVE DATA-DATE-6618-V6-X TO DATE-V6P-P.
- 198700 MOVE ACTN-CD-7350-V6-X TO ACTN-V6P-P.
- 198800 WRITE FDR-P1 FROM V6P-HDR-REC1 AFTER ADVANCING 2 LINES.
- 198900 WRITE FDR-P1 FROM V6P-HDR-REC2 AFTER ADVANCING 1 LINES.
- 199000 WRITE FDR-P1 FROM V6P-HDR-REC3 AFTER ADVANCING 1 LINES.
- 199100 WRITE FDR-P1 FROM REC-1-V6P-P AFTER ADVANCING 2 LINES.
- 199200 WRITE FDR-P1 FROM REC-1-V6P-AST AFTER ADVANCING 1 LINES.
- 199300 ADD 7 TO LIN-CNT.
- 199400 720-EXIT-1.
- 199500 EXIT.
- 199600 720-PRINT-V6-2.
- 199700 WRITE FDR-P1 FROM V6-HDR-REC4 AFTER ADVANCING 2 LINES.
- 199800 WRITE FDR-P1 FROM V6-HDR-REC5 AFTER ADVANCING 1 LINES.
- 199900 WRITE FDR-P1 FROM V6-HDR-REC6 AFTER ADVANCING 1 LINES.
- 200000 ADD 4 TO LIN-CNT.
- 200100 720-PRINT-V6-3.
- 200200 MOVE SPACE TO REC-2-V6-P.
- 200300 MOVE LIN-NUM-3578-V6-X TO LINE-V6-P.
- 200400 MOVE PLANT-CD-2646-V6-X TO PLANT-CD-V6-P.
- 200500 MOVE PHNO-STG-CD-3712-V6-X TO PHNO-V6-P.
- 200600 MOVE GRAMS-GRN-WGT-3941-V6-X TO GRN-WGT-V6-P.
- 200700 MOVE GRAMS-DRY-WGT-3942-V6-X TO DW-V6-P.
- 200800 MOVE ADW-PCT-3546-V6-X TO PCT-DW-V6-P.
- 200900 IF BASAL-DIMS-MIN-V6-X NOT = SPACE AND ZERO
- 201000 MOVE BAD-MIN-1-V6-X TO MIN-BAD-V6-P1
- 201100 MOVE BAD-MIN-2-V6-X TO MIN-BAD-V6-P3
- 201200 MOVE "." TO MIN-BAD-V6-P2.
- 201300 IF BASAL-DIMS-MAX-V6-X NOT = SPACE AND ZERO
- 201400 MOVE BAD-MAX-1-V6-X TO MAX-BAD-V6-P1
- 201500 MOVE BAD-MAX-2-V6-X TO MAX-BAD-V6-P3
- 201600 MOVE "." TO MAX-BAD-V6-P2.
- 201700 IF CROWN-DIMS-MIN-V6-X NOT = SPACE AND ZERO
- 201800 MOVE CRD-MIN-1-V6-X TO MIN-CRND-V6-P1
- 201900 MOVE CRD-MIN-2-V6-X TO MIN-CRND-V6-P3
- 202000 MOVE "." TO MIN-CRND-V6-P2.
- 202100 IF CROWN-DIMS-MIN-V6-X NOT = SPACE AND ZERO
- 202200 MOVE CRD-MAX-1-V6-X TO MAX-CRND-V6-P1
- 202300 MOVE CRD-MAX-2-V6-X TO MAX-CRND-V6-P3
- 202400 MOVE "." TO MAX-CRND-V6-P2.
- 202500 IF HGT-AVG-V6-X NOT = SPACE AND ZERO
- 202600 MOVE HGT-AVG-1-V6-X TO HGT-V6-P1
- 202700 MOVE HGT-AVG-2-V6-X TO HGT-V6-P3
- 202800 MOVE "." TO HGT-V6-P2.
- 202900 IF AVG-LDR-V6-X NOT = SPACE AND ZERO
- 203000 MOVE AVG-LDR-1-V6-X TO AVG-LDR-V6-P1
- 203100 MOVE AVG-LDR-2-V6-X TO AVG-LDR-V6-P3
- 203200 MOVE "." TO AVG-LDR-V6-P2.
- 203300 MOVE REC-CNT-V6-X TO REC-CNT-V6-P.
- 203400 WRITE FDR-P1 FROM REC-2-V6-P AFTER ADVANCING 2 LINES.
- 203500 ADD 2 TO LIN-CNT.
- 203600 IF AST-FLG = 1
- 203700 WRITE FDR-P1 FROM REC-2-V6-AST AFTER ADVANCING 1 LINES
- 203800 ADD 1 TO LIN-CNT.
- 203900 720-EXIT.
- 204000 EXIT.
- 204100 730-PRINT-VU-1.
- 204200 MOVE SPACE TO REC-1-VU-P.
- 204300 MOVE DIC-VU-X TO REC-VU-P.
- 204400 MOVE BLM-ADM-U-0003-ST-VU-X TO ST-VU-P.
- 204500 MOVE BLM-ADM-U-0003-DIST-VU-X TO DIST-VU-P.
- 204600 MOVE BLM-ADM-U-0003-RA-VU-X TO RA-VU-P.
- 204700 MOVE BLM-ADM-U-0003-PLU-VU-X TO PLU-VU-P.
- 204800 MOVE DATA-DATE-6618-VU-X TO DATE-VU-P.
- 204900 MOVE ACTN-CD-7350-VU-X TO ACTN-VU-P.
- 205000 MOVE DIET-USE-TYP-3917-VU-X TO PUFDT-VU-P.
- 205100 WRITE FDR-P1 FROM VU-HDR-REC1 AFTER ADVANCING 2 LINES.
- 205200 WRITE FDR-P1 FROM VU-HDR-REC2 AFTER ADVANCING 1 LINES.
- 205300 WRITE FDR-P1 FROM VU-HDR-REC3 AFTER ADVANCING 1 LINES.
- 205400 WRITE FDR-P1 FROM REC-1-VU-P AFTER ADVANCING 2 LINES.
- 205500 WRITE FDR-P1 FROM REC-1-VU-AST AFTER ADVANCING 1 LINES.
- 205600 ADD 7 TO LIN-CNT.
- 205700 730-EXIT-1.
- 205800 EXIT.
- 205900 730-PRINT-VU-2.
- 206000 MOVE SPACE TO REC-1-VU-P.
- 206100 WRITE FDR-P1 FROM VU-HDR-REC4 AFTER ADVANCING 2 LINES.
- 206200 WRITE FDR-P1 FROM VU-HDR-REC5 AFTER ADVANCING 1 LINES.
- 206300 WRITE FDR-P1 FROM VU-HDR-REC6 AFTER ADVANCING 1 LINES.
- 206400 ADD 4 TO LIN-CNT.
- 206500 730-PRINT-VU-3.
- 206600 MOVE SPACE TO REC-2-VU-P.
- 206700 MOVE LIN-NUM-3578-VU-X TO LINE-VU-P.
- 206800 MOVE PLANT-CD-2646-VU-X TO PLANT-CD-VU-P.
- 206900 MOVE AUF-3928-VU-X (1) TO PLNT-SPG-VU-P.
- 207000 MOVE AUF-3928-VU-X (2) TO PLNT-SUM-VU-P.
- 207100 MOVE AUF-3928-VU-X (3) TO PLNT-FAL-VU-P.
- 207200 MOVE AUF-3928-VU-X (4) TO PLNT-WIN-VU-P.
- 207300 MOVE AUF-3928-VU-X (5) TO PLNT-YRL-VU-P.
- 207400 MOVE ANML-GRZG-CD-3929-VU-X TO ANML-SP-VU-P.
- 207500 MOVE PUF-3511-VU-X (1) TO ANML-SPG-VU-P.
- 207600 MOVE PUF-3511-VU-X (2) TO ANML-SUM-VU-P.
- 207700 MOVE PUF-3511-VU-X (3) TO ANML-FAL-VU-P.
- 207800 MOVE PUF-3511-VU-X (4) TO ANML-WIN-VU-P.
- 207900 MOVE PUF-3511-VU-X (5) TO ANML-YRL-VU-P.
- 208000 WRITE FDR-P1 FROM REC-2-VU-P AFTER ADVANCING 2 LINES.
- 208100 ADD 2 TO LIN-CNT.
- 208200 IF AST-FLG = 1
- 208300 WRITE FDR-P1 FROM REC-2-VU-AST AFTER ADVANCING 1 LINES
- 208400 ADD 1 TO LIN-CNT.
- 208500 730-EXIT.
- 208600 EXIT.
- 208700 800-OFLO.
- 208800 MOVE 1 TO HEAD-SW.
- 208900 ADD 1 TO PAG-CNT.
- 209000 MOVE PAG-CNT TO HDR-PG MOVE 3 TO LIN-CNT.
- 209100 WRITE FDR-P1 FROM HDR-1 AFTER ADVANCING PAGE.
- 209200 WRITE FDR-P1 FROM HDR-2 AFTER ADVANCING 2 LINES.
- 209300 IF CUR-PRINT NOT = LAST-PRINT
- 209400 ADD 3 TO LIN-CNT
- 209500 WRITE FDR-P1 FROM HDR-3 AFTER ADVANCING 2 LINES
- 209600 WRITE FDR-P1 FROM HDR-4 AFTER ADVANCING 1 LINES.
- 209700 MOVE CUR-PRINT TO LAST-PRINT.
- 209800 800-EXIT.
- 209900 EXIT.
- 210000 999-END.
- 210100 STOP RUN.
- 210200*991.........2........3.........4.........5.........6.........7..
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES127M.
- 000300* V7 / V6 & VP PLANT MATCH (SEE REMARKS)
- 000400*
- 000500 AUTHOR. FRANK WILEY, RON BAKER.
- 000600 DATE-WRITTEN. 29 OCT 79 CHANGE 13 DEC 79.
- 000700 DATE-COMPILED.
- 000800*REMARKS: THE V7 IS READ AND A SORT RECORD IS RELEASED FOR
- 000900* EACH SPECIES WITHIN THE RECORD. THESE RECORDS ARE
- 001000* SORTED BY SDRP AND SPECIES. DUPLICATE SPECIES
- 001100* ARE WRITTEN ON AN ERROR LISTING.
- 001200* THE V6FUP AND THE V7 FILE ARE THEN SORTED
- 001300* BY ST,DIS,RA,PLU AND SPECIES. THE VF AND VU RECORDS
- 001400* ARE BYPASSED, THE V6 AND VP ARE
- 001500* ARE USED BY MATCHING THE V7 RECORD ON THE SORTED
- 001600* FIELDS, UNMATCHED V7 RECORDS ARE WRITTEN ON AN
- 001700* ERROR LISTING.
- 001800* RECORDS WHICH MATCH ARE LOADED INTO A TABLE AND ALL
- 001900* LIKE (SPECIES) V6,VP RECORDS ARE REPRODUCED FOR EACH
- 002000* DUPE SPECIES WITHIN THE MATCHING V7 RECORD. THE
- 002100* V7 SPECIES ARE ALSO EDITED VS THE DATA BASE DICTIONARY
- 002200* AND NO MATCH OR BAD PLANT-TYPES ARE WRITTEN TO AN
- 002300* ERROR LISTING IN RECORD FORMAT.
- 002400* THE NEW-V6VP RECORDS ARE SORTED BEFORE FINAL OUTPUT
- 002500* TO REMOVE THE OLD DUPLICATES THAT WERE SUPERCEDED
- 002600* BY THE V7 EQUALVALENTS.
- 002700 ENVIRONMENT DIVISION.
- 002800 CONFIGURATION SECTION.
- 002900 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 003000 OBJECT-COMPUTER. LEVEL-66-ASCII, SEQUENCE IS EBCDIC.
- 003100 INPUT-OUTPUT SECTION.
- 003200 FILE-CONTROL.
- 003300 SELECT ADW-FCTR-FILE ASSIGN TO D1
- 003400 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 003500 SELECT FILE-V7 ASSIGN TO I1
- 003600 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 003700 SELECT FILE-V6FUP ASSIGN TO I2
- 003800 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 003900 SELECT PRINT-FILE ASSIGN TO P1-PRINTER
- 004000 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 004100 SELECT PRINT-FILE-2 ASSIGN TO P2-PRINTER
- 004200 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 004300 SELECT SORT-FILE ASSIGN TO W1
- 004400 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 004500 DATA DIVISION.
- 004600 SUB-SCHEMA SECTION.
- 004700 DB CODVAL2 WITHIN BLMDIC.
- 004800 FILE SECTION.
- 004900 FD PRINT-FILE
- 005000 CODE-SET GBCD
- 005100 LABEL RECORD STANDARD.
- 005200 01 PRINT-REC PIC X(132).
- 005300 FD PRINT-FILE-2
- 005400 CODE-SET GBCD
- 005500 LABEL RECORD STANDARD.
- 005600 01 PRINT-REC-2 PIC X(132).
- 005700 FD FILE-V6FUP
- 005800 CODE-SET GBCD
- 005900 LABEL RECORD STANDARD.
- 006000 01 V6FUP-REC.
- 006100 02 FORM-CODE PIC XX.
- 006200 02 CMPL-RCD.
- 006300 03 FILLER PIC XX.
- 006400 03 SDRP-V6 PIC X(8).
- 006500 03 FILLER PIC X(11).
- 006600 03 PLANT-SYMBOL-V6 PIC X(7).
- 006700 03 FILLER PIC X(36).
- 006800 FD FILE-V7
- 006900 CODE-SET GBCD
- 007000 LABEL RECORD STANDARD.
- 007100 01 RCD-V7.
- 007200 02 RCD-TYPE PIC X(4).
- 007300 02 SDRP-V7 PIC X(8).
- 007400 02 FILLER PIC X(7).
- 007500 02 LINE-NO PIC 9(4).
- 007600 02 PLANT-SYMBOL-V7 PIC X(7).
- 007700 02 NEW-PLANT.
- 007800 03 PLANT-V7 OCCURS 8 PIC X(7).
- 007900 02 FILLER PIC X(4).
- 008000 FD ADW-FCTR-FILE
- 008100 CODE-SET GBCD
- 008200 LABEL RECORD STANDARD.
- 008300 01 ADW-FCTR-REC.
- 008400 02 REC-TYP-V6P PIC XX.
- 008500 02 FILLER PIC XX.
- 008600 02 SDRP-V6P.
- 008700 04 SDR-V6P.
- 008800 06 SD-V6P.
- 008900 08 ST-V6P PIC XX.
- 009000 08 DIST-V6P PIC XX.
- 009100 06 RA-V6P PIC XX.
- 009200 04 PLU-V6P PIC XX.
- 009300 02 FILLER PIC X(6).
- 009400 02 ACT-V6P PIC X.
- 009500 02 LINE-V6P PIC XXXX.
- 009600 02 PLANT-SYM-V6P PIC X(7).
- 009700 02 PHENO-V6P PIC X.
- 009800 02 FILLER PIC X(31).
- 009900 02 PLANT-TYP-VP PIC X.
- 010000 02 PLANT-TYP-V6 PIC X.
- 010100 02 FILLER PIC XX.
- 010200 SD SORT-FILE.
- 010300 01 SORT-RCD.
- 010400 02 SORT-KEY.
- 010500 03 SDRP-S PIC X(8).
- 010600 03 PLANT-SYMBOL-S PIC X(7).
- 010700 03 S-NUM PIC X(01).
- 010800 02 DATA-S PIC X(90).
- 010900 02 FILLER PIC XX.
- 011000 01 SORT-TWO.
- 011100 02 FILLER PIC X(4).
- 011200 02 SDRP-S7 PIC X(8).
- 011300 02 FILLER PIC X(11).
- 011400 02 PLANT-SYM-S7 PIC X(7).
- 011500 02 FILLER PIC X(60).
- 011600 01 SORT-THREE.
- 011700 03 SORT-KEY-W7.
- 011800 05 SDRP-W7 PIC X(8).
- 011900 05 PLANT-SYMBOL-W7 PIC X(7).
- 012000 03 S-NUM-W7 PIC 9.
- 012100 03 DATA-W7 PIC X(90).
- 012200 03 AST-W7 PIC 99.
- 012300 01 SORT-FOUR.
- 012400 02 SR-KEY.
- 012500 03 SDRP-SR.
- 012600 05 ST-SR PIC XX.
- 012700 05 DS-SR PIC XX.
- 012800 05 RA-SR PIC XX.
- 012900 05 PU-SR PIC XX.
- 013000 03 PLT-TYP-SR PIC X.
- 013100 03 PLT-PHENO-SR.
- 013200 05 PLT-SR PIC X(7).
- 013300 05 PHENO-SR PIC X.
- 013400 03 A-B-CD-SR PIC X.
- 013500 03 REC-TYP-SR PIC XXXX.
- 013600 02 SR-DATA PIC X(66).
- 013700 WORKING-STORAGE SECTION.
- 013800 77 FIRST-SW COMP-4 PIC 9 VALUE 1.
- 013900 77 FIRST-BY-SW COMP-4 PIC 9 VALUE 0.
- 014000 77 PLANT-DISP PIC X(7) VALUE SPACE.
- 014100 77 RTN-SW COMP-4 PIC 9 VALUE 0.
- 014200 77 LINE-CNT-2 PIC 99 VALUE ZERO.
- 014300 77 LINE-CNT PIC 99 VALUE ZERO.
- 014400 77 CNT-12 PIC 9(8) VALUE ZERO.
- 014500 77 CNT-13 PIC 9(8) VALUE ZERO.
- 014600 77 CNT-14 PIC 9(8) VALUE ZERO.
- 014700 77 CNT-15 PIC 9(8) VALUE ZERO.
- 014800 77 CNT-16 PIC 9(8) VALUE ZERO.
- 014900 77 CNT-17 PIC 9(8) VALUE ZERO.
- 015000 77 CNT-18 PIC 9(8) VALUE ZERO.
- 015100 77 CNT-19 PIC 9(8) VALUE ZERO.
- 015200 77 CNT-20 PIC 9(8) VALUE ZERO.
- 015300 77 SORT-KEY-DUPE PIC X(16) VALUE SPACE.
- 015400 77 ERR-SW COMP-4 PIC 9 VALUE 0.
- 015500 77 ERR-FLG COMP-4 PIC 9 VALUE 0.
- 015600 77 V7-CNTL-HLD PIC X(15) VALUE SPACE.
- 015700 77 PG-CNT-2 PIC 9(5) VALUE ZERO.
- 015800 77 PG-CNT PIC 9(5) VALUE ZERO.
- 015900 77 OFLO-CNT PIC 99 VALUE ZERO.
- 016000 77 W7-CNT PIC 9(8) VALUE ZERO.
- 016100 77 SUB COMP-4 PIC 99 VALUE 0.
- 016200 77 SUB-V7 COMP-4 PIC 99 VALUE 0.
- 016300 77 SUB-W7 COMP-4 PIC 99 VALUE 0.
- 016400 77 EQUAL-SW COMP-4 PIC 9 VALUE ZERO.
- 016500 01 VP-BYPASS-HLD.
- 016600 03 PLT-BY-VP PIC X(7).
- 016700 03 PHENO-BY-VP PIC X.
- 016800 01 V6-BYPASS-HLD.
- 016900 03 PLT-BY-V6 PIC X(7).
- 017000 03 PHENO-BY-V6 PIC X.
- 017100 01 AST-LINE.
- 017200 03 FILLER PIC X(23) VALUE SPACE.
- 017300 03 AST-P PIC X(7).
- 017400 03 AST PIC X(7) OCCURS 8 TIMES.
- 017500 03 FILLER PIC XXXX VALUE SPACE.
- 017600 01 SORT-HOLD-W7.
- 017700 03 SORT-KEY-HOLD-W7.
- 017800 05 SDRP-HOLD-W7 PIC X(8).
- 017900 05 PLANT-SYMBOL-HOLD-W7 PIC X(7).
- 018000 03 S-NUM-HOLD-W7 PIC 9.
- 018100 03 DATA-HOLD-W7 PIC X(90).
- 018200 03 FILLER PIC XX.
- 018300 01 V7-HOLD.
- 018400 02 V7-CNTL.
- 018500 03 SDRP-H PIC X(8) VALUE SPACE.
- 018600 03 PLANT-SYMBOL-H PIC X(7) VALUE SPACE.
- 018700 02 PLANT-TAB.
- 018800 03 PLANT-H OCCURS 40 TIMES PIC X(56).
- 018900 03 TYPE-H OCCURS 40 TIMES PIC X(8).
- 019000 01 HOLD-PLANTS.
- 019100 03 HLD-PLTS PIC X(7) OCCURS 8 TIMES.
- 019200 01 HOLD-TYPES.
- 019300 03 HLD-TYPS PIC X OCCURS 8 TIMES.
- 019400 01 WORK-TYPES.
- 019500 03 WRK-TYPS PIC X OCCURS 8 TIMES.
- 019600 01 V6-HOLD.
- 019700 02 V6-CNTL.
- 019800 03 SDRP-HLD PIC X(8).
- 019900 03 PLANT-SYMBOL-HLD PIC X(7).
- 020000 01 SORT-BUILD.
- 020100 02 BUILD-SORT PIC X(66).
- 020200 02 FILLER PIC X(24).
- 020300 01 DIS-CNTS.
- 020400 03 CNT-1 PIC 9(8) VALUE ZERO.
- 020500 03 FILLER PIC X VALUE SPACE.
- 020600 03 CNT-2 PIC 9(8) VALUE ZERO.
- 020700 03 FILLER PIC X VALUE SPACE.
- 020800 03 CNT-3 PIC 9(8) VALUE ZERO.
- 020900 03 FILLER PIC X VALUE SPACE.
- 021000 03 CNT-4 PIC 9(8) VALUE ZERO.
- 021100 03 FILLER PIC X VALUE SPACE.
- 021200 03 CNT-5 PIC 9(8) VALUE ZERO.
- 021300 03 FILLER PIC X VALUE SPACE.
- 021400 03 CNT-6 PIC 9(8) VALUE ZERO.
- 021500 03 FILLER PIC X VALUE SPACE.
- 021600 03 CNT-7 PIC 9(8) VALUE ZERO.
- 021700 03 FILLER PIC X VALUE SPACE.
- 021800 03 CNT-8 PIC 9(8) VALUE ZERO.
- 021900 03 FILLER PIC X VALUE SPACE.
- 022000 03 CNT-9 PIC 9(8) VALUE ZERO.
- 022100 03 FILLER PIC X VALUE SPACE.
- 022200 03 CNT-10 PIC 9(8) VALUE ZERO.
- 022300 03 FILLER PIC X VALUE SPACE.
- 022400 03 CNT-11 PIC 9(8) VALUE ZERO.
- 022500 01 BY-DISP.
- 022600 03 FILLER PIC X VALUE SPACE.
- 022700 03 ST-BY PIC XX.
- 022800 03 FILLER PIC X VALUE SPACE.
- 022900 03 DS-BY PIC XX.
- 023000 03 FILLER PIC X VALUE SPACE.
- 023100 03 RA-BY PIC XX.
- 023200 03 FILLER PIC X VALUE SPACE.
- 023300 03 PU-BY PIC XX.
- 023400 03 FILLER PIC XX VALUE SPACE.
- 023500 03 PLT-BY PIC X(7).
- 023600 03 FILLER PIC X VALUE SPACE.
- 023700 03 REC-BY PIC XX.
- 023800 01 BY-MSG.
- 023900 03 FILLER PIC X(25) VALUE "THE FOLLOWING PLANTS WERE".
- 024000 03 FILLER PIC X(23) VALUE " REPLACED BY THE VALUES".
- 024100 03 FILLER PIC X(23) VALUE " IN THEIR EQUIVALENT V7".
- 024200 03 FILLER PIC X(7) VALUE " PLANT.".
- 024300 01 BY-HDR.
- 024400 03 FILLER PIC X(22) VALUE " ST DS RA PLU PLANT ".
- 024500 03 FILLER PIC X(6) VALUE "RECORD".
- 024600 01 HDR-1.
- 024700 05 FILLER PIC X(24) VALUE " PCN: SV127E AS OF ".
- 024800 05 HDR-DD PIC XX.
- 024900 05 FILLER PIC X VALUE SPACE.
- 025000 05 HDR-MMM PIC XXX.
- 025100 05 FILLER PIC X VALUE SPACE.
- 025200 05 HDR-YR PIC XX.
- 025300 05 FILLER PIC X(11) VALUE SPACES.
- 025400 05 FILLER PIC X(45) VALUE
- 025500 "USDI- BUR OF LAND MGT SOIL-VEG INVENT METHOD".
- 025600 05 FILLER PIC X(32) VALUE SPACES.
- 025700 05 FILLER PIC X(5) VALUE "PAGE:".
- 025800 05 HDR-PG PIC ZZZZZ9.
- 025900 01 HDR-2.
- 026000 05 FILLER PIC X(50) VALUE SPACES.
- 026100 05 RMK-HDR-2 PIC X(16) VALUE
- 026200 "V7 ERROR LISTING".
- 026300 05 RMK-HDR-2B PIC X(21) VALUE " (DUPLICATE SPECIES)".
- 026400 05 FILLER PIC X(45) VALUE SPACES.
- 026500 01 HDR-3.
- 026600 05 FILLER PIC X(50) VALUE SPACES.
- 026700 05 RMK-HDR-3 PIC X(16) VALUE
- 026800 "V7 ERROR LISTING".
- 026900 05 RMK-HDR-3B PIC X(24) VALUE " (UNMATCHED V6 SPECIES)".
- 027000 05 FILLER PIC X(42) VALUE SPACES.
- 027100 COPY DBSTATUS OF TPCOBOLIB.
- 027200 01 HOLD-AREA.
- 027300 03 CODE-DEC-H.
- 027400 05 FILLER PIC XXXX.
- 027500 05 PLANT-CD-H PIC X(7).
- 027600 05 FILLER PIC X(24).
- 027700 05 PLANT-TYP-H PIC X.
- 027800 03 DE-CD-NAM-8823-DEC-H.
- 027900 05 DIST-NAM-H PIC X(15).
- 028000 05 FILLER PIC X(9).
- 028100 03 HLD-PLANT-CD PIC X(7).
- 028200 03 HLD-PLANT-TYP PIC X.
- 028300 03 DAT-H.
- 028400 05 YER-H PIC XX.
- 028500 05 MON-H PIC 99.
- 028600 05 DAY-H PIC XX.
- 028700 01 TABL-AREA.
- 028800 03 MON-V PIC X(36) VALUE "JANFEBMARAPRMAYJUNJULAUGSEPOCT
- 028900- "NOVDEC".
- 029000 03 MON-T REDEFINES MON-V PIC XXX OCCURS 12 TIMES.
- 029100 01 HDR-5.
- 029200 03 FILLER PIC X(30)
- 029300 VALUE "RECDSTDSRAPU-------LINE-PLANT-".
- 029400 03 FILLER PIC X(28)
- 029500 VALUE "-PLNT1--PLNT2--PLNT3--PLNT4-".
- 029600 03 FILLER PIC X(28)
- 029700 VALUE "-PLNT5--PLNT6--PLNT7--PLNT8-".
- 029800 03 FILLER PIC X(46) VALUE SPACE.
- 029900 01 DET-1.
- 030000 03 FILLER PIC X(86).
- 030100 03 FILLER PIC X(46).
- 030200 01 DET-2.
- 030300 03 FILLER PIC X(30).
- 030400 03 PLT-AST PIC X(7) OCCURS 8 TIMES.
- 030500 03 FILLER PIC X(46).
- 030600 01 P-SPACE PIC X(132) VALUE SPACE.
- 030700 PROCEDURE DIVISION.
- 030800 000-BEGIN SECTION.
- 030900 000-HOUSEKEEPING.
- 031000 MOVE SPACE TO AST-LINE.
- 031100 OPEN OUTPUT PRINT-FILE.
- 031200 OPEN OUTPUT PRINT-FILE-2.
- 031300 ACCEPT DAT-H FROM DATE.
- 031400 MOVE DAY-H TO HDR-DD.
- 031500 MOVE MON-T (MON-H) TO HDR-MMM.
- 031600 MOVE YER-H TO HDR-YR.
- 031700 000-OFLO.
- 031800 ADD 1 TO PG-CNT-2.
- 031900 MOVE 5 TO LINE-CNT-2.
- 032000 WRITE PRINT-REC-2 FROM P-SPACE BEFORE PAGE.
- 032100 MOVE PG-CNT-2 TO HDR-PG.
- 032200 MOVE SPACE TO DET-2.
- 032300 WRITE PRINT-REC-2 FROM HDR-1
- 032400 AFTER 1 LINE.
- 032500 WRITE PRINT-REC-2 FROM HDR-2 AFTER 2 LINES.
- 032600 WRITE PRINT-REC-2 FROM HDR-5
- 032700 AFTER 1 LINE.
- 032800 000-EXIT.
- 032900 EXIT.
- 033000 000-CONTINUE.
- 033100* DISPLAY "THE FOLLOWING PAIRS OF RECORDS".
- 033200* DISPLAY " CONTAIN DUPLICATE SPECIES CODES."
- 033300* DISPLAY " ".
- 033400 010-W7-SORT SECTION.
- 033500 015-SORT.
- 033600 SORT SORT-FILE ON ASCENDING KEY SORT-KEY-W7, S-NUM-W7
- 033700 INPUT PROCEDURE IS 020-BUILD-W7
- 033800 OUTPUT PROCEDURE IS 030-DUPE-CHK.
- 033900 015-W7-END.
- 034000 IF W7-CNT = ZERO
- 034100 DISPLAY " THERE WERE NO DUPLICATE SPECIES ON THE V7.".
- 034200 CLOSE FILE-V7.
- 034300 016-OFLO.
- 034400 ADD 1 TO PG-CNT.
- 034500 MOVE 5 TO LINE-CNT.
- 034600 WRITE PRINT-REC FROM P-SPACE BEFORE PAGE.
- 034700 MOVE PG-CNT TO HDR-PG.
- 034800 MOVE SPACE TO DET-2.
- 034900 WRITE PRINT-REC FROM HDR-1
- 035000 AFTER 1 LINE.
- 035100 WRITE PRINT-REC FROM HDR-3 AFTER 2 LINES.
- 035200 WRITE PRINT-REC FROM HDR-5
- 035300 AFTER 1 LINE.
- 035400 016-EXIT.
- 035500 EXIT.
- 035600 017-CONTINUE.
- 035700 MOVE SPACE TO HOLD-PLANTS PLANT-TAB.
- 035800 GO TO 040-V7-SORT.
- 035900 020-BUILD-W7 SECTION.
- 036000 020-OPEN.
- 036100 OPEN INPUT FILE-V7.
- 036200 020-READ.
- 036300 READ FILE-V7 AT END
- 036400 GO TO 020-EXIT.
- 036500 MOVE SPACE TO SORT-THREE.
- 036600 MOVE 1 TO S-NUM-W7.
- 036700 MOVE SDRP-V7 TO SDRP-W7.
- 036800 MOVE PLANT-SYMBOL-V7 TO PLANT-SYMBOL-W7.
- 036900 MOVE RCD-V7 TO DATA-W7.
- 037000 RELEASE SORT-THREE.
- 037100 MOVE ZERO TO SUB-W7.
- 037200 020-LP.
- 037300 IF SUB-W7 = 8
- 037400 GO TO 020-READ.
- 037500 ADD 1 TO SUB-W7.
- 037600 IF PLANT-V7 (SUB-W7) = SPACE
- 037700 GO TO 020-READ.
- 037800 MOVE SPACE TO SORT-THREE.
- 037900 MOVE 2 TO S-NUM-W7.
- 038000 MOVE SDRP-V7 TO SDRP-W7.
- 038100 MOVE RCD-V7 TO DATA-W7.
- 038200 MOVE PLANT-V7 (SUB-W7) TO PLANT-SYMBOL-W7.
- 038300 MOVE SUB-W7 TO AST-W7.
- 038400 RELEASE SORT-THREE.
- 038500 GO TO 020-LP.
- 038600 020-EXIT.
- 038700 EXIT.
- 038800 030-DUPE-CHK SECTION.
- 038900 030-RTN.
- 039000 RETURN SORT-FILE AT END
- 039100 GO TO 030-EXIT.
- 039200 MOVE SORT-THREE TO SORT-HOLD-W7.
- 039300 030-RTN2.
- 039400 RETURN SORT-FILE AT END
- 039500 GO TO 030-EXIT.
- 039600 IF SORT-KEY-W7 NOT = SORT-KEY-HOLD-W7
- 039700 MOVE SORT-THREE TO SORT-HOLD-W7
- 039800 GO TO 030-RTN2.
- 039900 IF (S-NUM-HOLD-W7 = S-NUM-W7) AND
- 040000 (S-NUM-HOLD-W7 = 1)
- 040100 GO TO 030-RTN2.
- 040200 ADD 1 TO W7-CNT.
- 040300 IF LINE-CNT-2 > 50
- 040400 PERFORM 000-OFLO THRU 000-EXIT.
- 040500 MOVE "*******" TO AST (AST-W7).
- 040600 MOVE DATA-HOLD-W7 TO DET-2.
- 040700 WRITE PRINT-REC-2 FROM DET-2 AFTER 1 LINE.
- 040800 MOVE DATA-W7 TO DET-2.
- 040900 WRITE PRINT-REC-2 FROM DET-2 AFTER 1 LINE.
- 041000 MOVE AST-LINE TO DET-2.
- 041100 WRITE PRINT-REC-2 FROM DET-2 AFTER 1 LINE.
- 041200 MOVE SPACE TO AST-LINE.
- 041300 MOVE SPACE TO DET-2.
- 041400 WRITE PRINT-REC-2 FROM DET-2 AFTER 1 LINE.
- 041500 ADD 4 TO LINE-CNT-2.
- 041600 GO TO 030-RTN2.
- 041700 030-EXIT.
- 041800 EXIT.
- 041900 040-V7-SORT SECTION.
- 042000 045-SORT.
- 042100 SORT SORT-FILE ON ASCENDING KEY SDRP-S7,
- 042200 PLANT-SYM-S7
- 042300 USING FILE-V7
- 042400 GIVING FILE-V7.
- 042500 050-V6-SORT SECTION.
- 042600 055-SORT-V6.
- 042700 SORT SORT-FILE ON ASCENDING KEY SORT-KEY
- 042800 INPUT PROCEDURE 065-BUILD-V6
- 042900 OUTPUT PROCEDURE 200-OUTPUT.
- 043000 IF CNT-11 = ZERO
- 043100 DISPLAY " ALL PLANTS WERE VERIFIED AGAINST THE DATA BASE"
- 043200 DISPLAY " INCLUDING HAVING A PROPER PLANT TYPE." .
- 043300 IF CNT-9 = ZERO
- 043400 DISPLAY " ALL V7 SPECIES RECORDS MATCHED.".
- 043500* DISPLAY DIS-CNTS.
- 043600 FINISH DIC-DE.
- 043700 CLOSE PRINT-FILE.
- 043800 CLOSE PRINT-FILE-2
- 043900 060-PASS-SORT SECTION.
- 044000 062-SORT-VERB.
- 044100 SORT SORT-FILE
- 044200 ASCENDING KEY SR-KEY
- 044300 INPUT PROCEDURE 800-INPUT
- 044400 OUTPUT PROCEDURE 900-OUTPUT.
- 044500 064-END.
- 044600 CLOSE ADW-FCTR-FILE.
- 044700 DISPLAY " NEW V6 RECORDS OUTPUT= " CNT-14.
- 044800 DISPLAY " NEW VP RECORDS OUTPUT= " CNT-15.
- 044900 DISPLAY " V6 RECORDS BYPASSED= " CNT-12.
- 045000 DISPLAY " VP RECORDS BYPASSED= " CNT-13.
- 045100 STOP RUN.
- 045200 065-BUILD-V6 SECTION.
- 045300 070-OPEN.
- 045400 OPEN INPUT FILE-V6FUP.
- 045500 075-READ.
- 045600 READ FILE-V6FUP AT END
- 045700 GO TO 100-CLOSE.
- 045800 IF FORM-CODE = "VU" OR "VF"
- 045900 GO TO 075-READ.
- 046000 MOVE SDRP-V6 TO SDRP-S.
- 046100 MOVE PLANT-SYMBOL-V6 TO PLANT-SYMBOL-S.
- 046200 MOVE ZERO TO S-NUM.
- 046300 IF FORM-CODE = "VP"
- 046400 ADD 1 TO CNT-7
- 046500 MOVE "3" TO S-NUM.
- 046600 IF FORM-CODE = "V6"
- 046700 ADD 1 TO CNT-8
- 046800 MOVE "4" TO S-NUM.
- 046900 MOVE V6FUP-REC TO BUILD-SORT.
- 047000 MOVE SORT-BUILD TO DATA-S.
- 047100 ADD 1 TO CNT-5.
- 047200 RELEASE SORT-RCD.
- 047300 GO TO 075-READ.
- 047400 100-CLOSE.
- 047500 CLOSE FILE-V6FUP.
- 047600 200-OUTPUT SECTION.
- 047700 210-OPEN.
- 047800 MOVE SPACE TO V7-CNTL V6-CNTL.
- 047900 OPEN OUTPUT ADW-FCTR-FILE.
- 048000 READY DIC-DE.
- 048100 OPEN INPUT FILE-V7.
- 048200 WRITE PRINT-REC-2 FROM P-SPACE BEFORE PAGE.
- 048300 MOVE 5 TO LINE-CNT-2.
- 048400 ADD 1 TO PG-CNT-2.
- 048500 MOVE PG-CNT-2 TO HDR-PG.
- 048600 MOVE SPACE TO DET-2.
- 048700 WRITE PRINT-REC-2 FROM HDR-1
- 048800 AFTER 1 LINE.
- 048900 MOVE " (INVALID SPECIES) " TO RMK-HDR-2B.
- 049000 WRITE PRINT-REC-2 FROM HDR-2 AFTER 2 LINES.
- 049100 WRITE PRINT-REC-2 FROM HDR-5
- 049200 AFTER 1 LINE.
- 049300 220-RETURN.
- 049400 IF (V6-CNTL = V7-CNTL) AND (V7-CNTL = HIGH-VALUE)
- 049500 GO TO 700-CLOSE.
- 049600 IF V6-CNTL = HIGH-VALUE AND (FIRST-SW = 0)
- 049700 GO TO 410-CONTROL.
- 049800 RETURN SORT-FILE AT END
- 049900 MOVE ZERO TO SUB-V7
- 050000 MOVE HIGH-VALUE TO SDRP-HLD PLANT-SYMBOL-HLD
- 050100 GO TO 410-CONTROL.
- 050200 ADD 1 TO CNT-1.
- 050300 IF (SORT-KEY = SORT-KEY-DUPE)
- 050400 DISPLAY "DUPE= " DATA-S
- 050500 GO TO 220-RETURN.
- 050600 IF S-NUM = "3"
- 050700 MOVE SORT-KEY TO SORT-KEY-DUPE.
- 050800 MOVE DATA-S TO SORT-BUILD.
- 050900 MOVE BUILD-SORT TO ADW-FCTR-REC.
- 051000 IF REC-TYP-V6P = "V6" OR "VP"
- 051100 MOVE "B" TO ACT-V6P.
- 051200 WRITE ADW-FCTR-REC.
- 051300 ADD 1 TO CNT-6.
- 051400 MOVE SDRP-S TO SDRP-HLD.
- 051500 MOVE PLANT-SYMBOL-S TO PLANT-SYMBOL-HLD.
- 051600 IF V6-CNTL = V7-CNTL-HLD
- 051700 GO TO 430-RESET-SUBS.
- 051800 MOVE ZERO TO SUB SUB-V7.
- 051900 MOVE SPACE TO HOLD-PLANTS PLANT-TAB.
- 052000 IF FIRST-SW = 1 MOVE ZERO TO FIRST-SW GO TO 400-READ-V7.
- 052100 ADD 1 TO CNT-10.
- 052200 IF V6-CNTL = V7-CNTL
- 052300 GO TO 410-CONTROL .
- 052400 IF V6-CNTL < V7-CNTL
- 052500 GO TO 220-RETURN.
- 052600 310-DISPLAY.
- 052700 MOVE RCD-V7 TO DET-1.
- 052800 IF LINE-CNT > 50
- 052900 PERFORM 016-OFLO THRU 016-EXIT.
- 053000 WRITE PRINT-REC FROM DET-1 AFTER 1 LINE.
- 053100 MOVE SPACE TO AST-LINE.
- 053200 MOVE "*******" TO AST-P.
- 053300 WRITE PRINT-REC FROM AST-LINE AFTER 2 LINES.
- 053400 ADD 3 TO LINE-CNT.
- 053500 ADD 1 TO CNT-9.
- 053600 320-ERR-CHK.
- 053700 IF ERR-SW = 1
- 053800 ADD 1 TO CNT-11
- 053900 PERFORM 620-PRINT THRU 620-EXIT.
- 054000 400-READ-V7.
- 054100 IF V7-CNTL = HIGH-VALUE AND (FIRST-SW = 0)
- 054200 GO TO 410-CONTROL.
- 054300 READ FILE-V7 AT END
- 054400 MOVE HIGH-VALUE TO SDRP-H PLANT-SYMBOL-H
- 054500 GO TO 420-CHK-PLANTS.
- 054600 PERFORM 600-DB-PLANT THRU 600-EXIT.
- 054700 ADD 1 TO CNT-3.
- 054800 MOVE SDRP-V7 TO SDRP-H.
- 054900 MOVE PLANT-SYMBOL-V7 TO PLANT-SYMBOL-H.
- 055000 410-CONTROL.
- 055100 IF (V6-CNTL = V7-CNTL) AND (V7-CNTL = HIGH-VALUE)
- 055200 GO TO 700-CLOSE.
- 055300 IF V6-CNTL = V7-CNTL
- 055400 ADD 1 TO SUB-V7
- 055500 MOVE NEW-PLANT TO PLANT-H (SUB-V7)
- 055600 MOVE HOLD-TYPES TO TYPE-H (SUB-V7)
- 055700 GO TO 320-ERR-CHK.
- 055800 IF V6-CNTL > V7-CNTL
- 055900 GO TO 310-DISPLAY.
- 056000 420-CHK-PLANTS.
- 056100 IF SUB-V7 = ZERO GO TO 220-RETURN.
- 056200 430-RESET-SUBS.
- 056300 MOVE ZERO TO SUB SUB-V7.
- 056400 MOVE V6-CNTL TO V7-CNTL-HLD.
- 056500 500-BUILD-OUTPUT.
- 056600 ADD 1 TO SUB-V7.
- 056700 IF SUB-V7 = 41 GO TO 220-RETURN.
- 056800 IF PLANT-H (SUB-V7) = SPACE GO TO 220-RETURN.
- 056900 MOVE PLANT-H (SUB-V7) TO HOLD-PLANTS.
- 057000 MOVE TYPE-H (SUB-V7) TO WORK-TYPES.
- 057100 510-LOOP.
- 057200 ADD 1 TO SUB.
- 057300 IF SUB = 9
- 057400 MOVE ZERO TO SUB
- 057500 GO TO 500-BUILD-OUTPUT.
- 057600 IF HLD-PLTS (SUB) = SPACE
- 057700 GO TO 510-LOOP.
- 057800 MOVE DATA-S TO SORT-BUILD.
- 057900 MOVE BUILD-SORT TO ADW-FCTR-REC.
- 058000 MOVE HLD-PLTS (SUB) TO PLANT-SYM-V6P.
- 058100 IF REC-TYP-V6P = "V6"
- 058200 MOVE WRK-TYPS (SUB) TO PLANT-TYP-V6
- 058300 ELSE MOVE WRK-TYPS (SUB) TO PLANT-TYP-VP.
- 058400 MOVE "A" TO ACT-V6P.
- 058500 WRITE ADW-FCTR-REC.
- 058600 ADD 1 TO CNT-4.
- 058700 GO TO 510-LOOP.
- 058800 600-DB-PLANT.
- 058900 MOVE ZERO TO SUB.
- 059000 MOVE SPACE TO HOLD-TYPES.
- 059100 601-LOOP.
- 059200 ADD 1 TO SUB.
- 059300 IF SUB = 9
- 059400 GO TO 600-EXIT.
- 059500 IF PLANT-V7 (SUB) = SPACE
- 059600 GO TO 601-LOOP.
- 059700 MOVE PLANT-V7 (SUB) TO HLD-PLANT-CD.
- 059800 PERFORM 610-DB-PLANT THRU 610-EXIT.
- 059900 IF ERR-FLG = 1
- 060000 MOVE 1 TO ERR-SW
- 060100 MOVE "*******" TO PLT-AST (SUB).
- 060200 IF ERR-FLG = 2
- 060300 MOVE 1 TO ERR-SW
- 060400 MOVE "****** " TO PLT-AST (SUB).
- 060500 GO TO 601-LOOP.
- 060600 600-EXIT.
- 060700 EXIT.
- 060800 610-DB-PLANT.
- 060900 MOVE ZERO TO ERR-FLG.
- 061000 MOVE HLD-PLANT-CD TO DE-CD-8822-DEC.
- 061100 MOVE 2646 TO DE-NO-8801-DEC.
- 061200 FIND ANY CODE-DEC.
- 061300 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 061400 IF NOT OK
- 061500 MOVE 1 TO ERR-FLG
- 061600 GO TO 610-EXIT.
- 061700 GET CODE-DEC.
- 061800 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 061900 IF NOT OK
- 062000 MOVE 1 TO ERR-FLG
- 062100 GO TO 610-EXIT.
- 062200 MOVE CODE-DEC TO CODE-DEC-H.
- 062300 IF PLANT-TYP-H NOT = "F" AND "G" AND "T" AND "S"
- 062400 MOVE 2 TO ERR-FLG
- 062500 GO TO 610-EXIT.
- 062600 MOVE PLANT-TYP-H TO HLD-TYPS (SUB).
- 062700 610-EXIT.
- 062800 EXIT.
- 062900 620-PRINT.
- 063000 MOVE 0 TO ERR-SW.
- 063100 IF LINE-CNT-2 > 50
- 063200 MOVE 5 TO LINE-CNT-2
- 063300 ADD 1 TO PG-CNT-2
- 063400 MOVE PG-CNT-2 TO HDR-PG
- 063500 WRITE PRINT-REC-2 FROM P-SPACE BEFORE PAGE
- 063600 WRITE PRINT-REC-2 FROM HDR-1
- 063700 AFTER 1 LINE
- 063800 WRITE PRINT-REC-2 FROM HDR-2 AFTER 2 LINES
- 063900 WRITE PRINT-REC-2 FROM HDR-5
- 064000 AFTER 1 LINE.
- 064100 MOVE RCD-V7 TO DET-1.
- 064200 WRITE PRINT-REC-2 FROM DET-1
- 064300 AFTER 1 LINE.
- 064400 WRITE PRINT-REC-2 FROM DET-2 AFTER 2 LINES.
- 064500 MOVE SPACE TO DET-2.
- 064600 ADD 3 TO LINE-CNT-2.
- 064700 620-EXIT.
- 064800 EXIT.
- 064900 700-CLOSE.
- 065000 CLOSE FILE-V7, ADW-FCTR-FILE.
- 065100 800-INPUT SECTION.
- 065200 810-OPEN.
- 065300 OPEN INPUT ADW-FCTR-FILE.
- 065400 820-READ.
- 065500 READ ADW-FCTR-FILE AT END
- 065600 GO TO 840-EXIT.
- 065700 MOVE SPACE TO SORT-FOUR.
- 065800 MOVE ADW-FCTR-REC TO SR-DATA.
- 065900 MOVE SDRP-V6P TO SDRP-SR.
- 066000 MOVE REC-TYP-V6P TO REC-TYP-SR.
- 066100 MOVE PLANT-SYM-V6P TO PLT-SR.
- 066200 MOVE ACT-V6P TO A-B-CD-SR.
- 066300 IF REC-TYP-V6P = "V6"
- 066400 MOVE PLANT-TYP-V6 TO PLANT-TYP-H
- 066500 MOVE PHENO-V6P TO PHENO-SR.
- 066600 IF REC-TYP-V6P = "VP"
- 066700 MOVE PLANT-TYP-VP TO PLANT-TYP-H
- 066800 MOVE SPACE TO PHENO-SR.
- 066900 IF PLANT-TYP-H = "G" MOVE "1" TO PLT-TYP-SR.
- 067000 IF PLANT-TYP-H = "F" MOVE "2" TO PLT-TYP-SR.
- 067100 IF PLANT-TYP-H = "S" OR "T" MOVE "3" TO PLT-TYP-SR.
- 067200 RELEASE SORT-FOUR.
- 067300 ADD 1 TO CNT-16.
- 067400 GO TO 820-READ.
- 067500 840-EXIT.
- 067600 EXIT.
- 067700 900-OUTPUT SECTION.
- 067800 910-OPEN.
- 067900 CLOSE ADW-FCTR-FILE.
- 068000 OPEN OUTPUT ADW-FCTR-FILE.
- 068100 920-RETURN.
- 068200 RETURN SORT-FILE AT END
- 068300 GO TO 970-EXIT.
- 068400 MOVE SR-DATA TO ADW-FCTR-REC.
- 068500 IF RTN-SW = ZERO
- 068600 MOVE 1 TO RTN-SW
- 068700 MOVE SDRP-SR TO SDRP-H.
- 068800 IF (A-B-CD-SR = "A") AND (REC-TYP-SR = "V6")
- 068900 MOVE PLT-SR TO PLT-BY-V6
- 069000 MOVE PHENO-SR TO PHENO-BY-V6.
- 069100 IF (A-B-CD-SR = "A") AND (REC-TYP-SR = "VP")
- 069200 MOVE PLT-SR TO PLT-BY-VP
- 069300 MOVE PHENO-SR TO PHENO-BY-VP.
- 069400 IF (SDRP-SR NOT = SDRP-H)
- 069500 MOVE SDRP-SR TO SDRP-H
- 069600 GO TO 950-WRITE.
- 069700 IF (A-B-CD-SR = "B") AND (REC-TYP-SR = "V6")
- 069800 AND (PLT-PHENO-SR = V6-BYPASS-HLD)
- 069900 ADD 1 TO CNT-12
- 070000 GO TO 960-CK-DISP.
- 070100 IF (A-B-CD-SR = "B") AND (REC-TYP-SR = "VP")
- 070200 AND (PLT-PHENO-SR = VP-BYPASS-HLD)
- 070300 ADD 1 TO CNT-13
- 070400 GO TO 960-CK-DISP.
- 070500 950-WRITE.
- 070600 IF REC-TYP-V6P = "VP"
- 070700 ADD 1 TO CNT-15.
- 070800 IF REC-TYP-V6P = "V6"
- 070900 ADD 1 TO CNT-14.
- 071000 WRITE ADW-FCTR-REC.
- 071100 GO TO 920-RETURN.
- 071200 960-CK-DISP.
- 071300 IF (FIRST-BY-SW = ZERO)
- 071400 MOVE 1 TO FIRST-BY-SW
- 071500 DISPLAY " "
- 071600 DISPLAY BY-MSG
- 071700 DISPLAY " "
- 071800 DISPLAY BY-HDR
- 071900 DISPLAY " ".
- 072000 IF PLANT-DISP NOT = PLT-SR
- 072100 MOVE PLT-SR TO PLANT-DISP
- 072200 MOVE ST-SR TO ST-BY
- 072300 MOVE DS-SR TO DS-BY
- 072400 MOVE RA-SR TO RA-BY
- 072500 MOVE PU-SR TO PU-BY
- 072600 MOVE PLT-SR TO PLT-BY
- 072700 MOVE REC-TYP-SR TO REC-BY
- 072800 DISPLAY BY-DISP.
- 072900 GO TO 920-RETURN.
- 073000 970-EXIT.
- 073100 EXIT.
- 073200 999-DUMMY SECTION.
- 073300 999-EXIT.
- 073400 EXIT.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES130M.
- 000300* CREATES SPECIES ADJUSTMENT FACTOR RECORD (SEE REMARKS)
- 000400*
- 000500 AUTHOR. RON BAKER.
- 000600*REMARKS. CALCULATES PERCENT PRODUCTION/ADJUSTMENT
- 000700* FACTOR BY PHENOLOGY STAGE & STORES SPEC-ADJ-FCTR-
- 000800* REC-PSA RECORD. INPUT IS ES127MD1.
- 000900* CALCULATIONS ARE ACCORDING TO P030 OF
- 001000* ESI USERS GUIDE.
- 001100* ALL PHRASES WITH "*" ON COL. 7 ARE USED FOR DEBUGGING.
- 001200*
- 001300 DATE-WRITTEN. 09/13/79.
- 001400 DATE-COMPILED.
- 001500 ENVIRONMENT DIVISION.
- 001600 CONFIGURATION SECTION.
- 001700 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001800 OBJECT-COMPUTER. LEVEL-66-ASCII.
- 001900 INPUT-OUTPUT SECTION.
- 002000 FILE-CONTROL.
- 002100 SELECT FILE-I1-I2 ASSIGN TO D1-D2
- 002200 ORGANIZATION IS INDEXED
- 002300 ACCESS MODE IS DYNAMIC
- 002400 RECORD KEY IS INDEX-KEY
- 002500 FILE STATUS IS FILE-STATUS.
- 002600 SELECT FILE-D1 ASSIGN TO I1
- 002700 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002800 SELECT FILE-P1 ASSIGN TO P1
- 002900 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 003000 SELECT SORT-WORK ASSIGN Z1.
- 003100 DATA DIVISION.
- 003200 FILE SECTION.
- 003300 FD FILE-D1
- 003400 CODE-SET IS GBCD
- 003500 LABEL RECORDS ARE STANDARD
- 003600 DATA RECORD IS FDR-D1.
- 003700 01 FDR-D1 PIC X(66).
- 003800 FD FILE-I1-I2
- 003900
- 004000 LABEL RECORDS ARE STANDARD
- 004100 BLOCK CONTAINS 8960 CHARACTERS
- 004200 RECORD CONTAINS 72 CHARACTERS
- 004300 DATA RECORD IS FDR-I1-I2.
- 004400 01 FDR-I1-I2.
- 004500 03 INDEX-KEY.
- 004600 05 SDRP-I1-I2 PIC X(8).
- 004700 05 PLANT-TYP-I1-I2 PIC 9.
- 004800 05 PLANT-CD-I1-I2 PIC X(7).
- 004900 03 DATA-I1-I2 PIC X(56).
- 005000 SD SORT-WORK
- 005100 DATA RECORD IS SORT-RCD.
- 005200 01 SORT-RCD.
- 005300 02 SR-KEY.
- 005400 03 SDRP-SR PIC X(8).
- 005500 03 PLT-TYP-SR PIC X.
- 005600 03 PLT-PHENO-SR.
- 005700 05 PLT-SR PIC X(7).
- 005800 05 PHENO-SR PIC X.
- 005900 03 A-B-CD-SR PIC X.
- 006000 03 REC-TYP-SR PIC XXXX.
- 006100 02 SR-DATA PIC X(66).
- 006200 FD FILE-P1
- 006300 CODE-SET IS GBCD
- 006400 LABEL RECORDS ARE STANDARD
- 006500 DATA RECORD IS FDR-P1.
- 006600 01 FDR-P1 PIC X(132).
- 006700 WORKING-STORAGE SECTION.
- 006800 01 FILE-STATUS.
- 006900 03 MAJOR-STATUS PIC X.
- 007000 03 MINOR-STATUS PIC X.
- 007100 77 I PIC 9(2) VALUE ZERO.
- 007200 77 CNT-1 PIC 9(6) VALUE ZERO.
- 007300 77 CNT-2 PIC 9(6) VALUE ZERO.
- 007400 77 DDD PIC Z,ZZZ,ZZZ.ZZZZZZ.
- 007500 77 EEE PIC Z,ZZZ,ZZZ.ZZZZZZ.
- 007600 77 FFF PIC Z,ZZZ,ZZZ.ZZZZZZ.
- 007700 77 GGG PIC Z,ZZZ,ZZZ.ZZZZZZ.
- 007800 77 HHH PIC Z,ZZZ,ZZZ.ZZZZZZ.
- 007900 77 MMTOT PIC 9(5)V9(6).
- 008000 77 MMQTR PIC 9(5)V9(6).
- 008100 77 QTRPIE PIC 9(5)V9(6).
- 008200 77 MAX-GRAMS PIC 9(7)V9(6) VALUE ZERO.
- 008300 77 GRAMS-PER-FT PIC 9(7)V9(6) VALUE ZERO.
- 008400 77 MIN-TEMP PIC 9(5)V9(4).
- 008500 77 MAX-TEMP PIC 9(5)V9(4).
- 008600 77 SQ-FT-TEMP PIC 9(5)V9(4) VALUE ZERO.
- 008700 77 LIN-CHK PIC 99 COMP-4.
- 008800 77 LIN-CNT PIC 99 COMP-4.
- 008900 77 PHNO-CNT PIC 99 COMP-4.
- 009000 77 PAG-CNT PIC 999 COMP-4.
- 009100 77 VP-PLT-CD-HLD PIC X(7) VALUE SPACE.
- 009200 77 PUF-CNT PIC 999 COMP-4.
- 009300 77 AUF-CNT PIC 999 COMP-4.
- 009400 77 ADW-HLD PIC 9(4)V99 VALUE ZERO.
- 009500 77 PCT-HLD PIC 999 VALUE ZERO.
- 009600 77 PHNO-STG-HLD PIC 9 VALUE ZERO.
- 009700 77 REC-CNT-PHNO-STG PIC 9999 VALUE ZERO.
- 009800 77 REC-CNT-PLANT-TOT PIC 9999 VALUE ZERO.
- 009900 77 PCT-TOT-HLD PIC 9(5) VALUE ZERO.
- 010000 77 PCT-TOT-PHNO-STG PIC 9(5) VALUE ZERO.
- 010100 77 PNNO-SW PIC 9 VALUE ZERO.
- 010200 77 DISPLAY-SW PIC 9 VALUE 0 COMP-4.
- 010300 77 FIRST-SW PIC 9 VALUE 1 COMP-4.
- 010400 77 SUB PIC 99 COMP-4.
- 010500 77 PHNO-SUB PIC 9 COMP-4.
- 010600 01 VP-BYPASS-HLD.
- 010700 03 PLT-BY-VP PIC X(7).
- 010800 03 PHENO-BY-VP PIC X.
- 010900 01 V6-BYPASS-HLD.
- 011000 03 PLT-BY-V6 PIC X(7).
- 011100 03 PHENO-BY-V6 PIC X.
- 011200******************************************************************
- 011300* "VP" PHENOLOGY ADJUSTMENT DATA.
- 011500 01 REC-VP-X.
- 011600 05 KEY-VP-X.
- 011700 10 DIC-VP-X.
- 011800 15 REC-TYP-3529-VP-X PIC X(2).
- 011900 15 FMT-NUM-3576-VP-X PIC X(1).
- 012000 15 FMT-CD-3579-VP-X PIC X(1).
- 012100 10 BLM-ADM-U-0003-VP-X.
- 012200 15 BLM-ADM-U-0003-ST-VP-X PIC X(2).
- 012300 15 BLM-ADM-U-0003-DIST-VP-X PIC X(2).
- 012400 15 BLM-ADM-U-0003-RA-VP-X PIC X(2).
- 012500 15 BLM-ADM-U-0003-PLU-VP-X PIC X(2).
- 012600 10 DATA-DATE-6618-VP-X.
- 012700 15 DATA-DATE-6618-YY-VP-X PIC X(2).
- 012800 15 DATA-DATE-6618-MM-VP-X PIC X(2).
- 012900 15 DATA-DATE-6618-DD-VP-X PIC X(2).
- 013000 10 ACTN-CD-7350-VP-X PIC X(1).
- 013100 10 LIN-NUM-3578-VP-X PIC X(4).
- 013200*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- 013300 05 PLANT-CD-2646-VP-X PIC X(7).
- 013400 05 PHNO-GP-VP-X PIC X(32).
- 013500 05 PHNO-ADJ-GP-VP-X REDEFINES PHNO-GP-VP-X.
- 013600 07 PHNO-ADJ-VP-X OCCURS 8 TIMES.
- 013700 09 PHNO-ADJ-1-VP-X PIC XX.
- 013800 09 PHNO-ADJ-2-VP-X PIC XX.
- 013900 05 PHNO-ADJ-FCTR-3545-VP-X REDEFINES PHNO-GP-VP-X
- 014000 OCCURS 8 TIMES PIC 99V99.
- 014100 05 PLANT-TYP-3590-VP-X PIC X.
- 014200 05 FILLER PIC XXX.
- 014500* "V6" DRY/GREEN WEIGHT CONVERSION FACTOR DATA.
- 014700 01 REC-V6-X.
- 014800 05 KEY-V6-X.
- 014900 10 DIC-V6-X.
- 015000 15 REC-TYP-3529-V6-X PIC X(2).
- 015100 15 FMT-NUM-3576-V6-X PIC X(1).
- 015200 15 FMT-CD-3579-V6-X PIC X(1).
- 015300 10 BLM-ADM-U-0003-V6-X.
- 015400 15 BLM-ADM-U-0003-ST-V6-X PIC X(2).
- 015500 15 BLM-ADM-U-0003-DIST-V6-X PIC X(2).
- 015600 15 BLM-ADM-U-0003-RA-V6-X PIC X(2).
- 015700 15 BLM-ADM-U-0003-PLU-V6-X PIC X(2).
- 015800 10 DATA-DATE-6618-V6-X.
- 015900 15 DATA-DATE-6618-YY-V6-X PIC X(2).
- 016000 15 DATA-DATE-6618-MM-V6-X PIC X(2).
- 016100 15 DATA-DATE-6618-DD-V6-X PIC X(2).
- 016200 10 ACTN-CD-7350-V6-X PIC X(1).
- 016300 10 LIN-NUM-3578-V6-X PIC X(4).
- 016400*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- 016500 05 PLANT-CD-2646-V6-X PIC X(7).
- 016600 05 PHNO-STG-CD-3712-V6-X PIC 9(1).
- 016700 05 GRAMS-GRN-WGT-3941-V6-X PIC 9(4).
- 016800 05 ADW-PCT-3546-V6-X PIC 9V99.
- 016900 05 ADW-PCT-V6-X-RD REDEFINES ADW-PCT-3546-V6-X PIC 999.
- 017000 05 GRAMS-DRY-WGT-3942-V6-X PIC 9(4).
- 017100 05 GRP-1-V6-X.
- 017200 07 BASAL-DIMS-3533-MIN-V6-X PIC 99V99.
- 017300 07 BASAL-DIMS-3533-MAX-V6-X PIC 99V99.
- 017400 07 CROWN-DIMS-3534-MIN-V6-X PIC 99V9.
- 017500 07 CROWN-DIMS-3534-MAX-V6-X PIC 99V9.
- 017600 07 HGT-AVG-3504-V6-X PIC 999V9.
- 017700 07 AVG-LDR-LGT-7313-V6-X PIC 99V9.
- 017800 05 GRP-1-RD-V6-X REDEFINES GRP-1-V6-X.
- 017900 07 BASAL-DIMS-MIN-V6-X.
- 018000 09 BAD-MIN-1-V6-X PIC XX.
- 018100 09 BAD-MIN-2-V6-X PIC XX.
- 018200 07 BASAL-DIMS-MAX-V6-X.
- 018300 09 BAD-MAX-1-V6-X PIC XX.
- 018400 09 BAD-MAX-2-V6-X PIC XX.
- 018500 07 CROWN-DIMS-MIN-V6-X.
- 018600 09 CRD-MIN-1-V6-X PIC XX.
- 018700 09 CRD-MIN-2-V6-X PIC X.
- 018800 07 CROWN-DIMS-MAX-V6-X.
- 018900 09 CRD-MAX-1-V6-X PIC XX.
- 019000 09 CRD-MAX-2-V6-X PIC X.
- 019100 07 HGT-AVG-V6-X.
- 019200 09 HGT-AVG-1-V6-X PIC XXX.
- 019300 09 HGT-AVG-2-V6-X PIC X.
- 019400 07 AVG-LDR-V6-X.
- 019500 09 AVG-LDR-1-V6-X PIC XX.
- 019600 09 AVG-LDR-2-V6-X PIC X.
- 019700 05 PLANT-TYP-V6-X PIC X.
- 019800 05 REC-CNT-V6-X PIC 99.
- 019900******************************************************************
- 020000 01 SPEC-AFR.
- 020100 03 SDRP-AFR PIC X(8).
- 020200 03 PLANT-TYP-AFR PIC X.
- 020300 03 PLANT-CD-AFR PIC X(7).
- 020400 03 ADW-PCT-GP-AFR PIC X(24).
- 020500 03 ADW-PCT-AFR REDEFINES ADW-PCT-GP-AFR
- 020600 OCCURS 8 TIMES PIC 999.
- 020700 03 PAF-GP-AFR PIC X(32).
- 020800 03 PAF-AFR REDEFINES PAF-GP-AFR
- 020900 OCCURS 8 TIMES PIC 99V99.
- 021000******************************************************************
- 021100 01 HDR-1.
- 021200 05 FILLER PIC X(24) VALUE " PCN: ES140M AS OF ".
- 021300 05 HDR-DD PIC XX.
- 021400 05 FILLER PIC X VALUE SPACE.
- 021500 05 HDR-MMM PIC XXX.
- 021600 05 FILLER PIC X VALUE SPACE.
- 021700 05 HDR-YR PIC XX.
- 021800 05 FILLER PIC X(09) VALUE SPACES.
- 021900 05 FILLER PIC X(48) VALUE
- 022000 "USDI- BUR OF LAND MGT ECOLOGICAL SITE INVENTORY".
- 022100 05 FILLER PIC X(31) VALUE SPACES.
- 022200 05 FILLER PIC X(5) VALUE "PAGE:".
- 022300 05 HDR-PG PIC ZZZZZ9.
- 022400 01 HDR-2.
- 022500 05 FILLER PIC X(17) VALUE SPACES.
- 022600 05 FILLER PIC X(8) VALUE "STATE: ".
- 022700 05 HDR-ST-NM PIC X(10).
- 022800 05 FILLER PIC X(16) VALUE SPACES.
- 022900 05 FILLER PIC X(7) VALUE "DIST: ".
- 023000 05 HDR-DIST-NM PIC X(15).
- 023100 05 FILLER PIC X(5) VALUE SPACES.
- 023200 05 RMK-HDR-2 PIC X(40) VALUE SPACE.
- 023300 05 FILLER PIC X(9) VALUE SPACES.
- 023400 01 HDR-3 PIC X(132).
- 023500 01 HDR-4 PIC X(132).
- 023600 01 FDR-D1-WK.
- 023700 03 CNTL-D1.
- 023800 05 REC-TYP-D1 PIC XXXX.
- 023900 05 SDRP-D1.
- 024000 07 SDR-D1.
- 024100 09 SD-D1.
- 024200 11 ST-D1 PIC XX.
- 024300 11 DIST-D1 PIC XX.
- 024400 09 RA-D1 PIC XX.
- 024500 07 PLU-D1 PIC XX.
- 024600 05 DATE-D1 PIC X(6).
- 024700 05 ACTN-D1 PIC X.
- 024800 05 LINE-D1 PIC XXXX.
- 024900 05 PLANT-CD-D1 PIC X(7).
- 025000 05 PHENO-D1 PIC X.
- 025100 03 DATA-D1.
- 025200 05 FILLER PIC X(31).
- 025300 05 PLANT-TYP-VP-D1 PIC X.
- 025400 05 PLANT-TYP-V6-D1 PIC X.
- 025500 05 REC-CNT-V6-D1 PIC 99.
- 025600 01 CNTL-HLD.
- 025700 03 REC-TYP-HLD PIC XXXX.
- 025800 03 SDRP-HLD.
- 025900 05 SDR-HLD.
- 026000 07 SD-HLD.
- 026100 09 ST-HLD PIC XX.
- 026200 09 DIST-HLD PIC XX.
- 026300 07 RA-HLD PIC XX.
- 026400 05 PLU-HLD PIC XX.
- 026500 03 DATE-HLD PIC X(6).
- 026600 03 ACTN-HLD PIC X.
- 026700 03 LINE-HLD PIC XXXX.
- 026800 03 PLANT-CD-HLD PIC X(7).
- 026900 03 PHENO-HLD PIC X.
- 027000 01 HLD-NAMES.
- 027100 03 FUNC-HLD.
- 027200 05 ST-NM-HLD PIC X(10).
- 027300 05 FILLER PIC X(14).
- 027400 03 EXPL-HLD.
- 027500 05 DIST-NM-HLD PIC X(11).
- 027600 05 FILLER PIC X.
- 027700 05 RA-NM-HLD PIC X(12).
- 027800 05 FILLER PIC X.
- 027900 05 PU-NM-HLD PIC X(15).
- 028000 05 FILLER PIC X.
- 028100 01 HOLD-AREA.
- 028200 03 CT-CODE-TABLE-H.
- 028300 05 FILLER PIC XXXX.
- 028400 05 PLANT-CD-H PIC X(7).
- 028500 05 FILLER PIC X(24).
- 028600 05 PLANT-TYP-H PIC X.
- 028700 03 CT-FUNC-NAM-H.
- 028800 05 DIST-NAM-H PIC X(15).
- 028900 05 FILLER PIC X(9).
- 029000 03 HLD-PLANT-CD PIC X(7).
- 029100 03 HLD-PLANT-TYP PIC X.
- 029200 03 HLD-ANML-CD PIC XX.
- 029300 03 DAT-H.
- 029400 05 YER-H PIC XX.
- 029500 05 MON-H PIC 99.
- 029600 05 DAY-H PIC XX.
- 029700 03 DATA-DATE-VP-HLD.
- 029800 05 DATA-YER-VP-HLD PIC XX.
- 029900 05 DATA-MON-VP-HLD PIC XX.
- 030000 05 DATA-DAY-VP-HLD PIC XX.
- 030100 03 D-DATE-CHK.
- 030200 05 D-YER-CHK PIC XX.
- 030300 05 D-MON-CHK PIC XX.
- 030400 05 D-DAY-CHK PIC XX.
- 030500 03 JDAY-H PIC 9(5).
- 030600 03 JDAY-P0-H PIC 9(5).
- 030700 03 J9-H REDEFINES JDAY-P0-H.
- 030800 05 1ST-2C-JDAY-P0-H PIC 99.
- 030900 05 LST-3C-JDAY-P0-H PIC 999.
- 031000 03 CNTS-IGB.
- 031100 05 CNT-VPI PIC 9(5) VALUE ZERO.
- 031200 05 FILLER PIC XX VALUE SPACE.
- 031300 05 CNT-V6I PIC 9(5) VALUE ZERO.
- 031400 05 FILLER PIC XX VALUE SPACE.
- 031500 05 CNT-SUM PIC 9(5) VALUE ZERO.
- 031600 05 FILLER PIC XX VALUE SPACE.
- 031700 01 TABL-AREA.
- 031800 03 MON-V PIC X(36) VALUE "JANFEBMARAPRMAYJUNJULAUGSEPOCT
- 031900- "NOVDEC".
- 032000 03 MON-T REDEFINES MON-V PIC XXX OCCURS 12 TIMES.
- 032100 01 BASAL-CROWN-AREA-PER-STG.
- 032200 03 RECNT OCCURS 8 TIMES PIC 9(5)V9(4).
- 032300*
- 032400*
- 032500 01 WGT-PER-STG.
- 032600 03 GPF-TOT OCCURS 8 TIMES PIC 9(7)V9(4).
- 032700*
- 032800*
- 032900 01 GRAMS-PER-SQ-FT.
- 033000 03 GRAMS-FT OCCURS 8 TIMES PIC 9(7)V9(4).
- 033100*
- 033200*
- 033300 01 PERCENT-PER-STG.
- 033400 03 PERSENT OCCURS 8 TIMES PIC 9(3)V9(4).
- 033500 01 ADW-PCT-TAB.
- 033600 03 ADW-PCT OCCURS 8 TIMES PIC 9(3).
- 033700*
- 033800*
- 033900 01 FINISHED PIC X(4).
- 034000 88 DONE VALUE " ".
- 034100*
- 034200*
- 034300 01 ADJ-FACTOR.
- 034400 03 ADJ-FAC OCCURS 8 TIMES PIC 99V99.
- 034500*
- 034600*
- 034700 01 V61Z-KEY.
- 034800 03 ADST PIC X(2).
- 034900 03 DIST PIC 9(2).
- 035000 03 RA PIC 9(2).
- 035100 03 PLU PIC 9(2).
- 035200*
- 035300*
- 035400 01 CROWN.
- 035500 03 CRN1 PIC X(3).
- 035600 03 CRN2 REDEFINES CRN1 PIC 99V9.
- 035700*
- 035800*
- 035900 01 BASAL.
- 036000 03 BSL1 PIC X(4).
- 036100 03 BSL2 REDEFINES BSL1 PIC 99V99.
- 036200*
- 036300 01 P-SPACE PIC X(132) VALUE SPACE.
- 036400 PROCEDURE DIVISION.
- 036500 000-HOUSEKEEPING SECTION.
- 036600 000-BEGIN.
- 036700 ACCEPT DAT-H FROM DATE. ACCEPT JDAY-H FROM DAY.
- 036800 MOVE DAY-H TO HDR-DD. MOVE MON-T (MON-H) TO HDR-MMM.
- 036900 MOVE YER-H TO HDR-YR.
- 037000 MOVE SPACE TO SPEC-AFR.
- 037100 INITIALIZE BASAL-CROWN-AREA-PER-STG
- 037200 WGT-PER-STG
- 037300 GRAMS-PER-SQ-FT
- 037400 PERCENT-PER-STG
- 037500 I
- 037600 MAX-TEMP
- 037700 MIN-TEMP
- 037800 MAX-GRAMS
- 037900 ADJ-FACTOR
- 038000 ADW-PCT-TAB
- 038100 SQ-FT-TEMP.
- 038200 100-SORT SECTION.
- 038300 110-SORT-VERB.
- 038400 SORT SORT-WORK
- 038500 ASCENDING KEY SR-KEY
- 038600 INPUT PROCEDURE 200-INPUT
- 038700 OUTPUT PROCEDURE 300-OUTPUT.
- 038800 150-END.
- 038900 CLOSE FILE-D1.
- 039000 CLOSE FILE-I1-I2.
- 039100 STOP RUN.
- 039200 200-INPUT SECTION.
- 039300 210-OPEN.
- 039400 OPEN INPUT FILE-D1.
- 039500 OPEN OUTPUT FILE-I1-I2.
- 039600 READ FILE-D1 AT END STOP RUN.
- 039700 MOVE FDR-D1 TO FDR-D1-WK.
- 039800 GO TO 230-BUILD-SORT.
- 039900 210-READ.
- 040000 READ FILE-D1 AT END
- 040100 GO TO 240-EXIT.
- 040200 MOVE FDR-D1 TO FDR-D1-WK.
- 040300 GO TO 230-BUILD-SORT.
- 040400 230-BUILD-SORT.
- 040500 IF REC-TYP-D1 = "VP1D" OR "V61D" NEXT SENTENCE ELSE
- 040600 GO TO 210-READ.
- 040700* IF PLANT-CD-D1 NOT = "AGSM " AND "SPGR "
- 040800* GO TO 210-READ.
- 040900* IF PLANT-CD-D1 NOT = "ALTE "
- 041000* GO TO 210-READ.
- 041100* IF PLANT-CD-D1 NOT = "AGSM "
- 041200* GO TO 210-READ.
- 041300 MOVE SPACE TO SORT-RCD.
- 041400 MOVE FDR-D1-WK TO SR-DATA.
- 041500 MOVE SDRP-D1 TO SDRP-SR.
- 041600 MOVE REC-TYP-D1 TO REC-TYP-SR.
- 041700 MOVE PLANT-CD-D1 TO PLT-SR.
- 041800 MOVE ACTN-D1 TO A-B-CD-SR.
- 041900 IF REC-TYP-D1 = "V61D"
- 042000 ADD 1 TO CNT-V6I
- 042100 MOVE PLANT-TYP-V6-D1 TO PLANT-TYP-H
- 042200 MOVE PHENO-D1 TO PHENO-SR.
- 042300 IF REC-TYP-D1 = "VP1D"
- 042400 ADD 1 TO CNT-VPI
- 042500 MOVE PLANT-TYP-VP-D1 TO PLANT-TYP-H
- 042600 MOVE SPACE TO PHENO-SR.
- 042700 IF PLANT-TYP-H = "G" MOVE "1" TO PLT-TYP-SR.
- 042800 IF PLANT-TYP-H = "F" MOVE "2" TO PLT-TYP-SR.
- 042900 IF PLANT-TYP-H = "S" OR "T" MOVE "3" TO PLT-TYP-SR.
- 043000 RELEASE SORT-RCD.
- 043100 GO TO 210-READ.
- 043200 240-EXIT.
- 043300 EXIT.
- 043400 300-OUTPUT SECTION.
- 043500 310-RTN-FIRST.
- 043600 RETURN SORT-WORK AT END STOP RUN.
- 043700 ADD 1 TO CNT-1.
- 043800 MOVE SR-DATA TO FDR-D1-WK.
- 043900 MOVE CNTL-D1 TO CNTL-HLD.
- 044000 GO TO 400-PROCESS.
- 044100 320-END-PROC.
- 044200 PERFORM 415-CAL-ADW-PCT THRU 415-EXIT.
- 044300 PERFORM 500-FINAL-CALCS.
- 044400 PERFORM 700-BUILD-SPEC-REC.
- 044500 GO TO 800-EXIT.
- 044600 400-PROCESS.
- 044700 IF DISPLAY-SW = 1
- 044800 DISPLAY FDR-D1-WK.
- 044900* IF THE KEY OR PLANT CODE CHANGES, CALCULATE & STORE THE
- 045000* PLANT PREVIOUSLY COLLECTED.
- 045100 IF REC-TYP-SR = "VP1D"
- 045200 MOVE FDR-D1-WK TO REC-VP-X ELSE
- 045300 MOVE FDR-D1-WK TO REC-V6-X.
- 045400 IF (SDRP-SR NOT = SDRP-HLD)
- 045500 AND (FIRST-SW = 0)
- 045600 PERFORM 415-CAL-ADW-PCT THRU 415-EXIT
- 045700 GO TO 430-SUM.
- 045800 IF DISPLAY-SW = 1
- 045900 DISPLAY "SRK= " SR-KEY.
- 046000 IF (A-B-CD-SR = "A") AND (REC-TYP-SR = "V61D")
- 046100 MOVE PLT-SR TO PLT-BY-V6
- 046200 MOVE PHENO-SR TO PHENO-BY-V6.
- 046300 IF (A-B-CD-SR = "A") AND (REC-TYP-SR = "VP1D")
- 046400 MOVE PLT-SR TO PLT-BY-VP
- 046500 MOVE PHENO-SR TO PHENO-BY-VP.
- 046600 IF (A-B-CD-SR = "B") AND (REC-TYP-SR = "V61D")
- 046700 AND (PLT-PHENO-SR = V6-BYPASS-HLD)
- 046800* DISPLAY "PASS " SR-DATA
- 046900 GO TO 420-RETURN.
- 047000 IF (A-B-CD-SR = "B") AND (REC-TYP-SR = "VP1D")
- 047100 AND (PLT-PHENO-SR = VP-BYPASS-HLD)
- 047200* DISPLAY "PASS " SR-DATA
- 047300 GO TO 420-RETURN.
- 047400 IF (PLT-SR NOT = PLANT-CD-HLD)
- 047500 AND (FIRST-SW = 0)
- 047600 PERFORM 415-CAL-ADW-PCT THRU 415-EXIT
- 047700 GO TO 430-SUM.
- 047800 IF REC-TYP-SR = "VP1D"
- 047900 MOVE PLANT-TYP-3590-VP-X TO PLANT-TYP-H
- 048000 MOVE PLT-SR TO VP-PLT-CD-HLD
- 048100 MOVE PHNO-GP-VP-X TO ADJ-FACTOR
- 048200 GO TO 420-RETURN.
- 048300 IF (PHENO-SR NOT = PHNO-STG-HLD)
- 048400 AND (FIRST-SW = 0)
- 048500 PERFORM 415-CAL-ADW-PCT THRU 415-EXIT.
- 048600*
- 048700* CALCULATE THE AIR DRY WEIGHT FOR EACH V6 RECORD.
- 048800*
- 048900 IF GRAMS-DRY-WGT-3942-V6-X = SPACE
- 049000 MOVE ZERO TO GRAMS-DRY-WGT-3942-V6-X.
- 049100 IF (ADW-PCT-3546-V6-X > ZERO) AND
- 049200 (GRAMS-DRY-WGT-3942-V6-X = ZERO)
- 049300 COMPUTE ADW-HLD ROUNDED = ADW-PCT-3546-V6-X *
- 049400 GRAMS-GRN-WGT-3941-V6-X
- 049500 MOVE ADW-HLD TO GRAMS-DRY-WGT-3942-V6-X
- 049600 ELSE
- 049700 MOVE GRAMS-DRY-WGT-3942-V6-X TO ADW-HLD.
- 049800 IF REC-CNT-V6-X = SPACE OR ZERO
- 049900 MOVE 01 TO REC-CNT-V6-X.
- 050000 ADD REC-CNT-V6-X TO REC-CNT-PHNO-STG.
- 050100 COMPUTE PCT-TOT-HLD = REC-CNT-V6-X * ADW-PCT-V6-X-RD.
- 050200 ADD PCT-TOT-HLD TO PCT-TOT-PHNO-STG.
- 050300 MOVE ZERO TO FIRST-SW.
- 050400 410-CAL-AREA.
- 050500 MOVE CNTL-D1 TO CNTL-HLD.
- 050600 MOVE PHENO-D1 TO PHNO-STG-HLD.
- 050700*
- 050800* CALCULATE THE AREA PER PHENO STAGE OF THE INCOMING RECORD.
- 050900*
- 051000* IF (SDRP-SR = "WY036829") AND (PLT-SR = "ALTE ")
- 051100* AND (DISPLAY-SW = ZERO)
- 051200* MOVE 3 TO DISPLAY-SW.
- 051300 MOVE PLANT-TYP-V6-X TO PLANT-TYP-H.
- 051400 IF PLANT-TYP-V6-X = "G"
- 051500 MOVE BASAL-DIMS-MIN-V6-X TO BSL1
- 051600 MOVE BSL2 TO MIN-TEMP
- 051700 MOVE BASAL-DIMS-MAX-V6-X TO BSL1
- 051800 MOVE BSL2 TO MAX-TEMP
- 051900 ELSE
- 052000 MOVE CROWN-DIMS-MIN-V6-X TO CRN1
- 052100 MOVE CRN2 TO MIN-TEMP
- 052200 MOVE CROWN-DIMS-MAX-V6-X TO CRN1
- 052300 MOVE CRN2 TO MAX-TEMP.
- 052400 IF (PLANT-TYP-V6-X = "G")
- 052500 AND (MIN-TEMP = ZERO)
- 052600 MOVE CROWN-DIMS-MIN-V6-X TO CRN1
- 052700 MOVE CRN2 TO MIN-TEMP
- 052800 MOVE CROWN-DIMS-MAX-V6-X TO CRN1
- 052900 MOVE CRN2 TO MAX-TEMP.
- 053000 IF (PLANT-TYP-V6-X = "F" OR "S" OR "T")
- 053100 AND (MIN-TEMP = ZERO)
- 053200 MOVE BASAL-DIMS-MIN-V6-X TO BSL1
- 053300 MOVE BSL2 TO MIN-TEMP
- 053400 MOVE BASAL-DIMS-MAX-V6-X TO BSL1
- 053500 MOVE BSL2 TO MAX-TEMP.
- 053600 COMPUTE MMTOT ROUNDED = MIN-TEMP * MAX-TEMP.
- 053700 COMPUTE MMQTR ROUNDED = MMTOT / 4.
- 053800 COMPUTE QTRPIE ROUNDED = MMQTR * 3.1417.
- 053900 COMPUTE SQ-FT-TEMP ROUNDED = QTRPIE * REC-CNT-V6-X.
- 054000 MOVE MMTOT TO EEE.
- 054100 MOVE MMQTR TO FFF.
- 054200 MOVE QTRPIE TO GGG.
- 054300 MOVE SQ-FT-TEMP TO DDD.
- 054400 IF DISPLAY-SW = 1
- 054500 DISPLAY "SF=" DDD " QP=" GGG " MQ=" FFF " MT=" EEE.
- 054600* ADD SQ-FT-TEMP TO RECNT (PHNO-STG-CD-3712-V6-X).
- 054700* ADD ADW-HLD TO
- 054800* GPF-TOT (PHNO-STG-CD-3712-V6-X).
- 054900 MOVE ZERO TO GRAMS-PER-FT.
- 055000 IF SQ-FT-TEMP NOT = ZERO
- 055100 COMPUTE GRAMS-PER-FT = ADW-HLD / SQ-FT-TEMP
- 055200 ADD 1 TO RECNT (PHNO-STG-CD-3712-V6-X)
- 055300 ADD GRAMS-PER-FT TO GPF-TOT (PHNO-STG-CD-3712-V6-X).
- 055400 IF DISPLAY-SW = 1
- 055500* MOVE RECNT (PHNO-STG-CD-3712-V6-X) TO DDD
- 055600 MOVE GRAMS-PER-FT TO DDD
- 055700 MOVE GPF-TOT (PHNO-STG-CD-3712-V6-X) TO GGG
- 055800 DISPLAY "GPF" DDD " GRF-TOT=" GGG.
- 055900 420-RETURN.
- 056000 RETURN SORT-WORK AT END
- 056100 GO TO 320-END-PROC.
- 056200 ADD 1 TO CNT-1.
- 056300 MOVE SR-DATA TO FDR-D1-WK.
- 056400 GO TO 400-PROCESS.
- 056500 415-CAL-ADW-PCT.
- 056600 IF PCT-TOT-PHNO-STG = ZERO
- 056700 GO TO 415-EXIT.
- 056800 COMPUTE PCT-HLD ROUNDED = PCT-TOT-PHNO-STG /
- 056900 REC-CNT-PHNO-STG.
- 057000 MOVE PCT-HLD TO ADW-PCT (PHNO-STG-HLD).
- 057100 IF DISPLAY-SW = 2
- 057200 MOVE PCT-HLD TO DDD
- 057300 MOVE PCT-TOT-PHNO-STG TO EEE
- 057400 MOVE REC-CNT-PHNO-STG TO FFF
- 057500 DISPLAY "PH=" DDD " PT=" EEE " RC=" FFF.
- 057600 MOVE ZERO TO PCT-TOT-PHNO-STG REC-CNT-PHNO-STG.
- 057700 415-EXIT.
- 057800 EXIT.
- 057900 430-SUM.
- 058000 PERFORM 415-CAL-ADW-PCT THRU 415-EXIT.
- 058100 PERFORM 500-FINAL-CALCS.
- 058200 PERFORM 700-BUILD-SPEC-REC.
- 058300 PERFORM 750-INITIALIZE.
- 058400 GO TO 400-PROCESS.
- 058500 GO TO 400-PROCESS.
- 058600 500-FINAL-CALCS.
- 058700* CALCULATE THE GRAMS PER SQ FT PER STAGE FOR PREVIOUSLY
- 058800* COLLECTED PLANT. DETERMINE THE GRAMS PER SQ FT AT FULL
- 058900* PRODUCTION (MAX-GRAMS).
- 059000 PERFORM 600-CALC-GRAMS VARYING I FROM 1 BY 1 UNTIL I > 8.
- 059100* CALCULATE THE PERCENT PER PHENOLOGY STAGE FOR PREVIOUSLY
- 059200* COLLECTED PLANT.
- 059300 PERFORM 610-CALC-PERCENT-OF-MAX VARYING I FROM 1 BY 1
- 059400 UNTIL I > 8.
- 059500 IF DISPLAY-SW = 1 OR 2 OR 3
- 059600 DISPLAY "PERCENTS OF MAX = " PERCENT-PER-STG.
- 059700* CALCULATE THE ADJUSTMENT FACTOR PER STAGE FOR PREVIOUSLY
- 059800* COLLECTED PLANT.
- 059900 PERFORM 620-CALC-ADJ VARYING I FROM 1 BY 1 UNTIL I > 8.
- 060000 IF DISPLAY-SW = 1 OR 2 OR 3
- 060100 DISPLAY "ADJ FACTORS = " ADJ-FACTOR.
- 060200 500-EXIT.
- 060300 EXIT.
- 060400 600-CALC-GRAMS.
- 060500 MOVE ZERO TO GRAMS-FT (I).
- 060600 IF RECNT (I) NOT = ZERO
- 060700 COMPUTE GRAMS-FT (I) = GPF-TOT (I) / RECNT (I).
- 060800 IF DISPLAY-SW = 1 OR 2 OR 3 AND (GRAMS-FT (I) > ZERO)
- 060900 MOVE GRAMS-FT (I) TO DDD
- 061000 MOVE GPF-TOT (I) TO EEE
- 061100 MOVE RECNT (I) TO FFF
- 061200 DISPLAY "GRAMS-FT (" I ") = " DDD
- 061300 " GPF-TOT (" I ") = " EEE
- 061400 " RECDS (" I ") = " FFF.
- 061500 IF RECNT (I) NOT = ZERO
- 061600 IF GRAMS-FT (I) > MAX-GRAMS
- 061700 MOVE GRAMS-FT (I) TO MAX-GRAMS.
- 061800 610-CALC-PERCENT-OF-MAX.
- 061900 MOVE ZERO TO PERSENT (I).
- 062000 IF GRAMS-FT (I) NOT = ZERO
- 062100 COMPUTE PERSENT (I) = GRAMS-FT (I) / MAX-GRAMS.
- 062200 IF DISPLAY-SW = 1 OR 2 OR 3 AND (PERSENT (I) > ZERO)
- 062300 MOVE PERSENT (I) TO DDD
- 062400 MOVE GRAMS-FT (I) TO EEE
- 062500 MOVE MAX-GRAMS TO FFF
- 062600 DISPLAY "PERSENT (" I ") = " DDD
- 062700 " GRAMS-FT (" I ") = " EEE
- 062800 " MAX-GRAMS = " FFF.
- 062900 620-CALC-ADJ.
- 063000 IF (PERSENT (I) NOT = ZERO)
- 063100 AND (ADJ-FAC (I) = ZERO OR SPACE)
- 063200 COMPUTE ADJ-FAC (I) ROUNDED = 1 / PERSENT (I).
- 063300 IF DISPLAY-SW = 1 OR 2 OR 3 AND (ADJ-FAC (I) > ZERO)
- 063400 MOVE PERSENT (I) TO DDD
- 063500 MOVE ADJ-FAC (I) TO EEE
- 063600 DISPLAY "PERSENT (" I ") = " DDD
- 063700 " ADJ-FAC (" I ") = " EEE.
- 063800 700-BUILD-SPEC-REC.
- 063900 MOVE SPACE TO SPEC-AFR.
- 064000 MOVE SDRP-HLD TO SDRP-AFR.
- 064100 MOVE PLANT-CD-HLD TO PLANT-CD-AFR
- 064200 IF PLANT-TYP-H = "G" MOVE "1" TO PLANT-TYP-AFR.
- 064300 IF PLANT-TYP-H = "F" MOVE "2" TO PLANT-TYP-AFR.
- 064400 IF PLANT-TYP-H = "S" OR "T" MOVE "3" TO PLANT-TYP-AFR.
- 064500 MOVE ADJ-FAC (1) TO PAF-AFR (1).
- 064600 MOVE ADJ-FAC (2) TO PAF-AFR (2).
- 064700 MOVE ADJ-FAC (3) TO PAF-AFR (3).
- 064800 MOVE ADJ-FAC (4) TO PAF-AFR (4).
- 064900 MOVE ADJ-FAC (5) TO PAF-AFR (5).
- 065000 MOVE ADJ-FAC (6) TO PAF-AFR (6).
- 065100 MOVE ADJ-FAC (7) TO PAF-AFR (7).
- 065200 MOVE ADJ-FAC (8) TO PAF-AFR (8).
- 065300 MOVE ADW-PCT (1) TO ADW-PCT-AFR (1).
- 065400 MOVE ADW-PCT (2) TO ADW-PCT-AFR (2).
- 065500 MOVE ADW-PCT (3) TO ADW-PCT-AFR (3).
- 065600 MOVE ADW-PCT (4) TO ADW-PCT-AFR (4).
- 065700 MOVE ADW-PCT (5) TO ADW-PCT-AFR (5).
- 065800 MOVE ADW-PCT (6) TO ADW-PCT-AFR (6).
- 065900 MOVE ADW-PCT (7) TO ADW-PCT-AFR (7).
- 066000 MOVE ADW-PCT (8) TO ADW-PCT-AFR (8).
- 066100 IF (DISPLAY-SW = 1 OR 2 OR 3)
- 066200 ADD 1 TO CNT-SUM
- 066300 DISPLAY SPEC-AFR.
- 066400* DISPLAY SPEC-AFR.
- 066500 ADD 1 TO CNT-2.
- 066600 MOVE SPEC-AFR TO FDR-I1-I2
- 066700 WRITE FDR-I1-I2 INVALID KEY
- 066800 DISPLAY INDEX-KEY FILE-STATUS.
- 066900 IF DISPLAY-SW = 1 OR 3 MOVE 0 TO DISPLAY-SW.
- 067000 750-INITIALIZE.
- 067100 MOVE CNTL-D1 TO CNTL-HLD.
- 067200 MOVE PHENO-SR TO PHNO-STG-HLD.
- 067300 INITIALIZE BASAL-CROWN-AREA-PER-STG
- 067400 WGT-PER-STG
- 067500 GRAMS-PER-SQ-FT
- 067600 PERCENT-PER-STG
- 067700 I
- 067800 MAX-TEMP
- 067900 MIN-TEMP
- 068000 MAX-GRAMS
- 068100 ADJ-FACTOR
- 068200 ADW-PCT-TAB
- 068300 SQ-FT-TEMP.
- 068400 800-EXIT.
- 068500 EXIT.
- 068600 900-DUMMY SECTION.
- 068700 999-END.
- 068800 STOP RUN.
- 068900*991.........2........3.........4.........5.........6.........7..
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES208M.
- 000300* CONVERTS NEW FORMAT VA RECORDS TO OLD FORMAT (D) RECORDS
- 000400*
- 000500 AUTHOR. GEORGIA BOSSE.
- 000600 INSTALLATION. BLM.
- 000700 DATE-WRITTEN. DECEMBER 1982.
- 000800*REMARKS. VA CONVERSION-D
- 000900* THE INPUT FILES ARE THE KEY ENTERED VA AND VB RECORDS.
- 001000* VA = BLM FORM 4412-29 (APRIL 1982)
- 001100* VB = BLM FORM 4412-30 (APRIL 1982)
- 001200* THE OUTPUT IS FORMATTED LIKE THE KEY ENTERED VA1D RECORDS
- 001300* VA1D = BLM FORM 4412-29 (JUNE 79)
- 001400* THE PROGRAM SORTS THE VA FILE BY SWA INTO A TEMPORARY FIL
- 001500* AND THEN SORTS THE VB FILE BY SWA. THE TWO FILES ARE MAT
- 001600* ON SWA# AND ALL VA RECORDS FOR WHICH THERE IS A MATCHING
- 001700* VB RECORD ARE REFORMATTED INTO THE VA1D FILE. IF NO MATC
- 001800* VB RECORD IS FOUND AN ERROR MESSAGE IS PRINTED AND THE PR
- 001900* READS THE NEXT VA RECORD. IF THE PROGRAM REACHES THE END
- 002000* OF THE VB FILE WITHOUT MATCHING THE VA SWA OR FINDING A H
- 002100* SWA THE PROGRAM PRINTS A MESSAGE AND TERMINATES.
- 002200 ENVIRONMENT DIVISION.
- 002300 CONFIGURATION SECTION.
- 002400 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 002500 OBJECT-COMPUTER. LEVEL-66-ASCII SEQUENCE IS EBCDIC.
- 002600 INPUT-OUTPUT SECTION.
- 002700 FILE-CONTROL.
- 002800 SELECT VA1D-FILE ASSIGN D1
- 002900 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 003000 SELECT VA-FILE ASSIGN I1
- 003100 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 003200 SELECT VB-FILE ASSIGN I2
- 003300 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 003400 SELECT VA-SORT-OUT-FILE ASSIGN DZ.
- 003500 SELECT VA-SORT-FILE ASSIGN ASORT.
- 003600 SELECT VB-SORT-FILE ASSIGN BSORT.
- 003700 DATA DIVISION.
- 003800 FILE SECTION.
- 003900 FD VA-FILE
- 004000 CODE-SET IS GBCD
- 004100 LABEL RECORDS ARE STANDARD
- 004200 DATA RECORD IS VA-REC.
- 004300 01 VA-REC.
- 004400 03 PG-NUM-I1 PIC 9999.
- 004500 03 INV-CD-I1 PIC XXXX.
- 004600 03 REC-TYP-I1 PIC XXX.
- 004700 03 MAP-TYP-I1 PIC XXX.
- 004800 03 GEO-ST-I1 PIC XX.
- 004900 03 MER-I1 PIC XX.
- 005000 03 MAP-QUAD-I1 PIC 9(8).
- 005100 03 LIN-NUM-I1 PIC 99.
- 005200 03 ACT-I1 PIC X.
- 005300 03 SWA-I1 PIC XXXX.
- 005400 03 ACRES-I1 PIC 9(5).
- 005500 03 TR-ID-I1 PIC X.
- 005600 03 SECT-I1 PIC 999.
- 005700 03 TWP-I1 PIC X(5).
- 005800 03 RNG-I1 PIC X(5).
- 005900 03 SURF-OWN-I1 PIC XXXX.
- 006000 03 ADM-I1 PIC X(4).
- 006100 03 JURIS-I1 PIC X(4).
- 006200 03 TYP-I1 PIC X(4).
- 006300 03 FILLER PIC X(16).
- 006400 FD VB-FILE
- 006500 CODE-SET IS GBCD
- 006600 LABEL RECORDS ARE STANDARD
- 006700 DATA RECORD IS VB-REC.
- 006800 01 VB-REC.
- 006900 03 PG-I2 PIC X(4).
- 007000 03 INV-CD-I2 PIC X(4).
- 007100 03 REC-TYP-I2 PIC XXX.
- 007200 03 RA-I2 PIC XX.
- 007300 03 PU-I2 PIC XX.
- 007400 03 ALLOT-I2 PIC X(4).
- 007500 03 PASTR-I2 PIC XX.
- 007600 03 LINE-NUM-I2 PIC XX.
- 007700 03 ACT-I2 PIC X.
- 007800 03 SWA-I2 PIC X(4).
- 007900 03 TRN-I2 PIC XX.
- 008000 03 PCT-SWA-I2 PIC XXX.
- 008100 03 STRAT-I2 PIC X(4).
- 008200 03 CLMTC-ADJ-FCTR-I2 PIC 99V999.
- 008300 03 ELEV-I2 PIC X(5).
- 008400 03 PCT-SLP-I2 PIC XXX.
- 008500 03 SLP-ASPT-I2 PIC XX.
- 008600 03 LND-FRM-I2 PIC XXX.
- 008700 03 SOIL-PHS-I2 PIC X(6).
- 008800 03 FILLER PIC X(23).
- 008900 FD VA1D-FILE
- 009000 CODE-SET IS GBCD
- 009100 LABEL RECORDS ARE STANDARD
- 009200 DATA RECORD IS VA1D-REC.
- 009300 01 VA1D-REC.
- 009400 03 REC-TYPE-D1 PIC X(4).
- 009500 03 STATE-DIST-D1 PIC X(4).
- 009600 03 RA-D1 PIC XX.
- 009700 03 PU-D1 PIC XX.
- 009800 03 ALLOT-D1 PIC X(4).
- 009900 03 PASTR-D1 PIC XX.
- 010000 03 DATE-D1 PIC X(6).
- 010100 03 ACT-D1 PIC X.
- 010200 03 MAP-SRC-D1 PIC X(4).
- 010300 03 MER-D1 PIC XX.
- 010400 03 LINE-NUM-D1 PIC X(4).
- 010500 03 TWP-D1 PIC X(5).
- 010600 03 RNG-D1 PIC X(5).
- 010700 03 SECT-D1 PIC XXX.
- 010800 03 SWA-D1 PIC X(4).
- 010900 03 QUARTERS-D1 PIC X(16).
- 011000 03 ACRES-D1 PIC X(5).
- 011100 03 SURF-OWN-D1 PIC X(4).
- 011200 03 JURIS-D1 PIC X(4).
- 011300 03 ADM-D1 PIC X(4).
- 011400 03 TYP-D1 PIC X(4).
- 011500 03 FIL PIC X.
- 011600 FD VA-SORT-OUT-FILE
- 011700 LABEL RECORDS ARE STANDARD
- 011800 DATA RECORD IS VA-SORT-OUT.
- 011900 01 VA-SORT-OUT.
- 012000 03 PG-NUM-SVA PIC 9999.
- 012100 03 INV-CD-SVA PIC XXXX.
- 012200 03 REC-TYP-SVA PIC XXX.
- 012300 03 MAP-TYP-SVA PIC XXX.
- 012400 03 GEO-ST-SVA PIC XX.
- 012500 03 MER-SVA PIC XX.
- 012600 03 MAP-QUAD-SVA PIC 9(8).
- 012700 03 LIN-NUM-SVA PIC 99.
- 012800 03 ACT-SVA PIC X.
- 012900 03 SWA-SVA PIC XXXX.
- 013000 03 ACRES-SVA PIC 9(5).
- 013100 03 TR-ID-SVA PIC X.
- 013200 03 SECT-SVA PIC 999.
- 013300 03 TWP-SVA PIC X(5).
- 013400 03 RNG-SVA PIC X(5).
- 013500 03 SURF-OWN-SVA PIC XXXX.
- 013600 03 ADM-SVA PIC X(4).
- 013700 03 JURIS-SVA PIC X(4).
- 013800 03 TYP-SVA PIC X(4).
- 013900 03 FILLER PIC X(16).
- 014000 SD VA-SORT-FILE
- 014100 DATA RECORD IS VA-SORT-REC.
- 014200 01 VA-SORT-REC.
- 014300 03 FILLER PIC X(29).
- 014400 03 SWA-IS-KEY PIC XXXX.
- 014500 03 FILLER PIC X(51).
- 014600 SD VB-SORT-FILE
- 014700 DATA RECORD IS VB-SORT-REC.
- 014800 01 VB-SORT-REC.
- 014900 03 PG-SVB PIC X(4).
- 015000 03 INV-SVB PIC X(4).
- 015100 03 REC-TYP-SVB PIC XXX.
- 015200 03 RA-SVB PIC XX.
- 015300 03 PU-SVB PIC XX.
- 015400 03 ALLOT-SVB PIC X(4).
- 015500 03 PASTR-SVB PIC XX.
- 015600 03 LINE-NUM-SVB PIC XX.
- 015700 03 ACT-SVB PIC X.
- 015800 03 SWA-SVB PIC X(4).
- 015900 03 TRN-SVB PIC XX.
- 016000 03 PCT-SWA-SVB PIC XXX.
- 016100 03 STRAT-SVB PIC X(4).
- 016200 03 CLMTC-ADJ-FCTR-SVB PIC 99V999.
- 016300 03 ELEV-SVB PIC X(5).
- 016400 03 PCT-SLP-SVB PIC XXX.
- 016500 03 SLP-ASPT-SVB PIC XX.
- 016600 03 LND-FRM-SVB PIC XXX.
- 016700 03 SOIL-PHS-SVB PIC X(6).
- 016800 03 FILLER PIC X(23).
- 016900 WORKING-STORAGE SECTION.
- 017000 77 ERR-CNT PIC 9 VALUE ZERO.
- 017100 77 VA1D-CNT PIC 99999 VALUE ZERO.
- 017200 77 TODAYS-DATE PIC X(06).
- 017300 01 INV-ST-DIST.
- 017400 03 INVENTORY PIC XXXX.
- 017500 03 STATE-DIST PIC X(4).
- 017600 PROCEDURE DIVISION.
- 017700 A100-HOUSE SECTION.
- 017800 A100-HOUSEKEEPING.
- 017900 ACCEPT TODAYS-DATE FROM DATE.
- 018000 ACCEPT INV-ST-DIST.
- 018100 B200-SORT-VA SECTION.
- 018200 B210-SORT-VA.
- 018300 SORT VA-SORT-FILE ON ASCENDING KEY
- 018400 SWA-IS-KEY
- 018500 INPUT PROCEDURE IS C300-INPUT-VA
- 018600 GIVING VA-SORT-OUT-FILE.
- 018700 B250-SORT-VB SECTION.
- 018800 B260-SORT-VB.
- 018900 CLOSE VA-FILE.
- 019000 SORT VB-SORT-FILE ON ASCENDING KEY
- 019100 SWA-SVB
- 019200 INPUT PROCEDURE IS D400-INPUT-VB
- 019300 OUTPUT PROCEDURE IS E600-OUTPUT.
- 019400 B290-STOP.
- 019500 CLOSE VA1D-FILE VA-SORT-OUT-FILE.
- 019600 DISPLAY " OUTPUT RECORDS=" VA1D-CNT
- 019700 STOP RUN.
- 019800 C300-INPUT-VA SECTION.
- 019900 C310-OPEN.
- 020000 MOVE ZERO TO ERR-CNT.
- 020100 OPEN INPUT VA-FILE.
- 020200 C320-READ-VA-FILE.
- 020300 READ VA-FILE AT END
- 020400 GO TO C300-EXIT.
- 020500 IF REC-TYP-I1 NOT = "VA "
- 020600 ADD 1 TO ERR-CNT
- 020700 DISPLAY " INVALID REC-TYP-I1 " VA-REC
- 020800 IF ERR-CNT = 5
- 020900 DISPLAY " CHECK COMPLETE FILE - ABORT - "
- 021000 STOP RUN
- 021100 ELSE
- 021200 GO TO C320-READ-VA-FILE.
- 021300 IF INVENTORY NOT = INV-CD-I1
- 021400 DISPLAY " INVENTORY UNMATCHED WITH VA-REC"
- 021500 DISPLAY " INVENTORY REQUESTED= " INVENTORY
- 021600 DISPLAY "THIS FILE IS " INV-CD-I1
- 021700 STOP RUN.
- 021800 MOVE VA-REC TO VA-SORT-REC.
- 021900 RELEASE VA-SORT-REC.
- 022000 GO TO C320-READ-VA-FILE.
- 022100 C300-EXIT.
- 022200 EXIT.
- 022300 D400-INPUT-VB SECTION.
- 022400 D410-OPEN.
- 022500 MOVE ZERO TO ERR-CNT.
- 022600 OPEN INPUT VB-FILE.
- 022700 D420-READ-VB-FILE.
- 022800 READ VB-FILE AT END
- 022900 GO TO D400-EXIT.
- 023000 IF REC-TYP-I2 NOT = "VB "
- 023100 ADD 1 TO ERR-CNT
- 023200 DISPLAY " INVALID REC-TYP-I2 " VB-REC
- 023300 IF ERR-CNT = 5
- 023400 DISPLAY " CHECK COMPLETE FILE - ABORT - "
- 023500 STOP RUN
- 023600 ELSE
- 023700 GO TO D420-READ-VB-FILE.
- 023800 IF INVENTORY NOT = INV-CD-I2
- 023900 DISPLAY " INVENTORY UNMATCHED WITH VB-REC"
- 024000 DISPLAY " INVENTORY REQUESTED= " INVENTORY
- 024100 DISPLAY "THIS FILE IS " INV-CD-I2
- 024200 STOP RUN.
- 024300 MOVE VB-REC TO VB-SORT-REC.
- 024400 RELEASE VB-SORT-REC.
- 024500 GO TO D420-READ-VB-FILE.
- 024600 D400-EXIT.
- 024700 EXIT.
- 024800 E600-OUTPUT SECTION.
- 024900 E610-OPEN.
- 025000 OPEN INPUT VA-SORT-OUT-FILE.
- 025100 OPEN OUTPUT VA1D-FILE.
- 025200 CLOSE VB-FILE.
- 025300 RETURN VB-SORT-FILE AT END
- 025400 DISPLAY "VB SORT FILE ERROR"
- 025500 STOP RUN.
- 025600 E620-RETURN.
- 025700 READ VA-SORT-OUT-FILE AT END
- 025800 GO TO E600-EXIT.
- 025900 IF SWA-SVA > SWA-SVB
- 026000 PERFORM E680-FIND-MATCH.
- 026100 IF SWA-SVA < SWA-SVB
- 026200 DISPLAY "SWA #" SWA-SVA
- 026300 " ON THE VA FILE HAS NO MATCHING SWA ON THE VB FILE"
- 026400 GO TO E620-RETURN.
- 026500* MOVE STANDARD FILE DATA
- 026600 MOVE STATE-DIST TO STATE-DIST-D1.
- 026700 MOVE "A" TO ACT-D1.
- 026800 MOVE TODAYS-DATE TO DATE-D1.
- 026900 MOVE "VA1D" TO REC-TYPE-D1.
- 027000 MOVE SPACES TO QUARTERS-D1.
- 027100 MOVE ZEROES TO LINE-NUM-D1.
- 027200* MOVE DATA FROM VB-RECORD
- 027300 MOVE SWA-SVB TO SWA-D1.
- 027400 MOVE RA-SVB TO RA-D1.
- 027500 MOVE PU-SVB TO PU-D1.
- 027600 MOVE ALLOT-SVB TO ALLOT-D1.
- 027700 MOVE PASTR-SVB TO PASTR-D1.
- 027800* MOVE DATA FROM VA-RECORD
- 027900 IF MAP-TYP-SVA = " "
- 028000 MOVE "MISC" TO MAP-SRC-D1.
- 028100 IF MAP-TYP-SVA = "TF "
- 028200 MOVE "GS " TO MAP-SRC-D1.
- 028300 IF MAP-TYP-SVA = "OQ "
- 028400 MOVE "OR " TO MAP-SRC-D1.
- 028500 IF MAP-TYP-SVA = "PL "
- 028600 MOVE "PM " TO MAP-SRC-D1.
- 028700 IF MAP-TYP-SVA = "BSP "
- 028800 MOVE "SP " TO MAP-SRC-D1.
- 028900 MOVE MER-SVA TO MER-D1.
- 029000 MOVE TWP-SVA TO TWP-D1.
- 029100 MOVE RNG-SVA TO RNG-D1.
- 029200 MOVE SECT-SVA TO SECT-D1.
- 029300 MOVE ACRES-SVA TO ACRES-D1.
- 029400 MOVE SURF-OWN-SVA TO SURF-OWN-D1.
- 029500 MOVE JURIS-SVA TO JURIS-D1.
- 029600 MOVE ADM-SVA TO ADM-D1.
- 029700 MOVE TYP-SVA TO TYP-D1.
- 029800 WRITE VA1D-REC.
- 029900 ADD 1 TO VA1D-CNT.
- 030000 GO TO E620-RETURN.
- 030100 E680-FIND-MATCH.
- 030200 RETURN VB-SORT-FILE AT END
- 030300 DISPLAY "CURRENT VA FILE IS AT SWA #" SWA-SVA
- 030400 DISPLAY "THERE ARE NO MORE SWAS ON THE VB FILE"
- 030500 GO TO E600-EXIT.
- 030600 IF SWA-SVA > SWA-SVB
- 030700 GO TO E680-FIND-MATCH.
- 030800 E600-EXIT.
- 030900 EXIT.
- 031000 DUMMY SECTION.
- 031100 D900-END.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES210U.
- 000300* INITIAL VA EDIT/UPDATE
- 000400*
- 000500 AUTHOR. CARLANDER.
- 000600 INSTALLATION. BLM.
- 000700 DATE-WRITTEN. SEPTEMBER, 1979.
- 000800 ENVIRONMENT DIVISION.
- 000900 CONFIGURATION SECTION.
- 001000 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001100 OBJECT-COMPUTER. LEVEL-66-ASCII SEQUENCE IS EBCDIC.
- 001200 INPUT-OUTPUT SECTION.
- 001300 FILE-CONTROL.
- 001400 SELECT NEW-FILE ASSIGN D1
- 001500 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001600 SELECT TRAN-FILE ASSIGN I1
- 001700 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001800 SELECT OPTIONAL PREV-FILE ASSIGN I2
- 001900 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002000 SELECT SORT-WORK ASSIGN I1 I2 I3.
- 002100*
- 002200 DATA DIVISION.
- 002300 FILE SECTION.
- 002400 FD PREV-FILE
- 002500 CODE-SET IS GBCD
- 002600 LABEL RECORDS ARE STANDARD
- 002700 DATA RECORD IS VA1X-RCD.
- 002800 01 VA1X-RCD.
- 002900 02 KEY-VA1X.
- 003000 03 DIC-VA1X.
- 003100 04 REC-TYP-3529-VA1X PIC X(02).
- 003200 04 FMT-NUM-3576-VA1X PIC X(01).
- 003300 04 FMT-CD-3579-VA1X PIC X(01).
- 003400 03 BLM-ADM-U-0003-VA1X.
- 003500 04 BLM-ADM-U-0003-ST-VA1X PIC X(02).
- 003600 04 BLM-ADM-U-0003-DIST-VA1X PIC X(02).
- 003700 04 BLM-ADM-U-0003-RA-VA1X PIC X(02).
- 003800 04 BLM-ADM-U-0003-PLU-VA1X PIC X(02).
- 003900 03 ALLOT-PAST-VA1X.
- 004000 05 ALLOT-NUM-0968-VA1X PIC X(04).
- 004100 05 PASTURE-NUM-3905-VA1X PIC X(02).
- 004200 03 DATA-DATE-6618-VA1X.
- 004300 04 DATA-DATE-6618-XY-VA1X PIC X(02).
- 004400 04 DATA-DATE-6618-MM-VA1X PIC X(02).
- 004500 04 DATA-DATE-6618-DD-VA1X PIC X(02).
- 004600 03 ACTN-CD-7350-VA1X PIC X(01).
- 004700 03 MAP-SRC-3540-VA1X PIC X(04).
- 004800 03 MTR-MER-CD-1703-VA1X PIC X(02).
- 004900 03 LIN-NUM-3578-VA1X PIC X(04).
- 005000 02 MTR-TWNSHP-1695-VA1X PIC X(05).
- 005100 02 MTR-RNG-1699-VA1X PIC X(05).
- 005200 02 SEC-SECT-2506-VA1X PIC X(03).
- 005300 02 SWA-3507-VA1X PIC X(04).
- 005400 02 ALIQ-PART-2904-VA1X PIC X(04) OCCURS 4.
- 005500 02 ACR-DU-6520-OWNR-VA1X PIC X(05).
- 005600 02 OWN-TYP-2531-VA1X PIC X(04).
- 005700 02 JURIS-2572-VA1X PIC X(04).
- 005800 02 MGT-ADM-2570-VA1X PIC X(04).
- 005900 02 LAND-TYP-3801-VA1X PIC X(04).
- 006000 02 OPEN-VA1X PIC X(01).
- 006100 SD SORT-WORK
- 006200 DATA RECORD IS SORT-RCD.
- 006300 01 SORT-RCD.
- 006400 03 CNTL-1-SR.
- 006500 05 REC-TYP-SR PIC XXXX.
- 006600 05 SDRP-SR PIC X(8).
- 006700 05 ALLOT-PAST-SR PIC X(6).
- 006800 03 FILLER PIC X(7).
- 006900 03 DATA-1-SR.
- 007000 05 MAP-SRC-SR PIC XXXX.
- 007100 05 MTR-MER-CD-SR PIC XX.
- 007200 03 LINE-SR PIC XXXX.
- 007300 03 DATA-2-SR.
- 007400 05 MTR-TWNSHP-SR PIC X(5).
- 007500 05 MTR-RNG-SR PIC X(5).
- 007600 05 SEC-SECT-SR PIC XXX.
- 007700 05 SWA-SR PIC XXXX.
- 007800 05 FILLER PIC X(37).
- 007900 03 FILLER PIC X.
- 008000 FD TRAN-FILE
- 008100 CODE-SET IS GBCD
- 008200 LABEL RECORDS ARE STANDARD
- 008300 DATA RECORD IS VA1K-RCD.
- 008400 01 VA1K-RCD.
- 008500 02 KEY-VA1K.
- 008600 03 DIC-VA1K.
- 008700 04 REC-TYP-3529-VA1K PIC X(02).
- 008800 04 FMT-NUM-3576-VA1K PIC X(01).
- 008900 04 FMT-CD-3579-VA1K PIC X(01).
- 009000 03 BLM-ADM-U-0003-VA1K.
- 009100 04 BLM-ADM-U-0003-ST-VA1K PIC X(02).
- 009200 04 BLM-ADM-U-0003-DIST-VA1K PIC X(02).
- 009300 04 BLM-ADM-U-0003-RA-VA1K PIC X(02).
- 009400 04 BLM-ADM-U-0003-PLU-VA1K PIC X(02).
- 009500 03 ALLOT-NUM-0968-VA1K PIC X(04).
- 009600 03 PASTURE-NUM-3905-VA1K PIC X(02).
- 009700 03 DATA-DATE-6618-VA1K.
- 009800 04 DATA-DATE-6618-XY-VA1K PIC X(02).
- 009900 04 DATA-DATE-6618-MM-VA1K PIC X(02).
- 010000 04 DATA-DATE-6618-DD-VA1K PIC X(02).
- 010100 03 ACTN-CD-7350-VA1K PIC X(01).
- 010200 03 MAP-SRC-3540-VA1K PIC X(04).
- 010300 03 MTR-MER-CD-1703-VA1K PIC X(02).
- 010400 03 LIN-NUM-3578-VA1K PIC X(04).
- 010500 02 MTR-TWNSHP-1695-VA1K PIC X(05).
- 010600 02 MTR-RNG-1699-VA1K PIC X(05).
- 010700 02 SEC-SECT-2506-VA1K PIC X(03).
- 010800 02 SWA-3507-VA1K PIC X(04).
- 010900 02 ALIQ-PART-2904-VA1K PIC X(04) OCCURS 4.
- 011000 02 ACR-DU-6520-OWNR-VA1K PIC X(05).
- 011100 02 OWN-TYP-2531-VA1K PIC X(04).
- 011200 02 JURIS-2572-VA1K PIC X(04).
- 011300 02 MGT-ADM-2570-VA1K PIC X(04).
- 011400 02 LAND-TYP-3801-VA1K PIC X(04).
- 011500 02 OPEN-VA1K PIC X(01).
- 011600 FD NEW-FILE
- 011700 CODE-SET IS GBCD
- 011800 LABEL RECORDS ARE STANDARD
- 011900 DATA RECORD IS VA1Z-RCD.
- 012000 01 VA1Z-RCD.
- 012100 02 KEY-VA1Z.
- 012200 03 DIC-VA1Z.
- 012300 04 REC-TYP-3529-VA1Z PIC X(02).
- 012400 04 FMT-NUM-3576-VA1Z PIC X(01).
- 012500 04 FMT-CD-3579-VA1Z PIC X(01).
- 012600 03 BLM-ADM-U-0003-VA1Z.
- 012700 04 BLM-ADM-U-0003-ST-VA1Z PIC X(02).
- 012800 04 BLM-ADM-U-0003-DIST-VA1Z PIC X(02).
- 012900 04 BLM-ADM-U-0003-RA-VA1Z PIC X(02).
- 013000 04 BLM-ADM-U-0003-PLU-VA1Z PIC X(02).
- 013100 03 ALLOT-PAST-VA1Z.
- 013200 05 ALLOT-NUM-0968-VA1Z PIC X(04).
- 013300 05 PASTURE-NUM-3905-VA1Z PIC X(02).
- 013400 03 DATA-DATE-6618-VA1Z.
- 013500 04 DATA-DATE-6618-XY-VA1Z PIC X(02).
- 013600 04 DATA-DATE-6618-MM-VA1Z PIC X(02).
- 013700 04 DATA-DATE-6618-DD-VA1Z PIC X(02).
- 013800 03 ACTN-CD-7350-VA1Z PIC X(01).
- 013900 03 MAP-SRC-3540-VA1Z PIC X(04).
- 014000 03 MTR-MER-CD-1703-VA1Z PIC X(02).
- 014100 03 LIN-NUM-3578-VA1Z PIC X(04).
- 014200 02 MTR-TWNSHP-1695-VA1Z PIC X(05).
- 014300 02 MTR-RNG-1699-VA1Z PIC X(05).
- 014400 02 SEC-SECT-2506-VA1Z PIC X(03).
- 014500 02 SWA-3507-VA1Z PIC X(04).
- 014600 02 ALIQ-PART-2904-VA1Z PIC X(04) OCCURS 4.
- 014700 02 ACR-DU-6520-OWNR-VA1Z PIC X(05).
- 014800 02 OWN-TYP-2531-VA1Z PIC X(04).
- 014900 02 JURIS-2572-VA1Z PIC X(04).
- 015000 02 MGT-ADM-2570-VA1Z PIC X(04).
- 015100 02 LAND-TYP-3801-VA1Z PIC X(04).
- 015200 02 OPEN-VA1Z PIC X(01).
- 015300 WORKING-STORAGE SECTION.
- 015400 77 END-OF-TRAN PIC X(01) VALUE SPACE.
- 015500 77 END-OF-PREV PIC X(01) VALUE SPACE.
- 015600 77 DATE-SW PIC X(01).
- 015700 77 DATE-MV-SW PIC X(01).
- 015800 77 LAST-LIN-NUM PIC 9(04) VALUE ZERO.
- 015900 77 TODAYS-DATE PIC X(06).
- 016000 77 VA-CTR PIC 9(5) VALUE ZERO.
- 016100*
- 016200 01 PARAMETER.
- 016300 03 RELINE-CHK PIC XXX.
- 016400 03 FILLER PIC X(77).
- 016500 01 DATE-WORK.
- 016600 02 DW-YY PIC X(02).
- 016700 02 DW-MM PIC X(02).
- 016800 02 DW-DD PIC X(02).
- 016900 01 MOVED-DATE.
- 017000 02 MD-DD PIC X(02).
- 017100 02 MD-YY PIC X(02).
- 017200 02 MD-MM PIC X(02).
- 017300 01 TRAN-CTL.
- 017400 03 REC-TYP-TC PIC XXXX.
- 017500 03 SDRP-TC PIC X(8).
- 017600 03 ALLOT-PAST-TC PIC X(6).
- 017700 03 LINE-TC PIC XXXX.
- 017800 01 PREV-CTL.
- 017900 03 REC-TYP-PC PIC XXXX.
- 018000 03 SDRP-PC PIC X(8).
- 018100 03 ALLOT-PAST-PC PIC X(6).
- 018200 03 LINE-PC PIC XXXX.
- 018300 01 CTL.
- 018400 03 REC-TYP-C PIC XXXX.
- 018500 03 SDRP-C PIC X(8).
- 018600 03 ALLOT-PAST-C PIC X(6).
- 018700 01 CTL-SAVE.
- 018800 03 REC-TYP-CS PIC XXXX.
- 018900 03 SDRP-CS PIC X(8).
- 019000 03 ALLOT-PAST-CS PIC X(6).
- 019100*
- 019200 PROCEDURE DIVISION.
- 019300 000-DRIVER SECTION.
- 019400 010-MAINLINE.
- 019500 PERFORM 100-INITIALIZE.
- 019600 PERFORM 200-SORT.
- 019700 PERFORM 990-TERMINATE.
- 019800 STOP RUN.
- 019900*
- 020000 100-INITIALIZE SECTION.
- 020100 110-OPENS.
- 020200 OPEN INPUT PREV-FILE TRAN-FILE
- 020300 OUTPUT NEW-FILE.
- 020400 MOVE ALL "9" TO PREV-CTL.
- 020500 ACCEPT PARAMETER.
- 020600 ACCEPT TODAYS-DATE FROM DATE.
- 020700*
- 020800 200-SORT SECTION.
- 020900 210-SORT-VERB.
- 021000 SORT SORT-WORK ASCENDING KEY
- 021100 REC-TYP-SR SDRP-SR ALLOT-PAST-SR
- 021200 LINE-SR SWA-SR MTR-MER-CD-SR MTR-RNG-SR
- 021300 MTR-TWNSHP-SR SEC-SECT-SR
- 021400 INPUT PROCEDURE 300-READ-RELEASE
- 021500 OUTPUT PROCEDURE 400-MATCH-UPDATE.
- 021600*
- 021700 300-READ-RELEASE SECTION.
- 021800 300-READ-TRAN.
- 021900 READ TRAN-FILE AT END GO TO 300-EXIT.
- 022000 IF ACTN-CD-7350-VA1K = SPACE
- 022100 MOVE "A" TO ACTN-CD-7350-VA1K.
- 022200 IF (LIN-NUM-3578-VA1K NOT NUMERIC) OR
- 022300 (LIN-NUM-3578-VA1K = "0000")
- 022400 OR (RELINE-CHK = "YES")
- 022500 MOVE "9999" TO LIN-NUM-3578-VA1K.
- 022600 MOVE VA1K-RCD TO SORT-RCD.
- 022700 RELEASE SORT-RCD.
- 022800 GO TO 300-READ-TRAN.
- 022900 300-EXIT.
- 023000 EXIT.
- 023100 400-MATCH-UPDATE SECTION.
- 023200 410-GET-FIRST-RCDS.
- 023300 PERFORM 430-RETURN-SORT.
- 023400 PERFORM 440-READ-PREV.
- 023500 420-COMPARE.
- 023600 IF TRAN-CTL = ALL "9" AND
- 023700 PREV-CTL = ALL "9"
- 023800 GO TO 400-EXIT.
- 023900 IF TRAN-CTL IS GREATER THAN PREV-CTL
- 024000 PERFORM 500-NO-TRAN
- 024100 GO TO 420-COMPARE.
- 024200 IF PREV-CTL IS GREATER THAN TRAN-CTL
- 024300 PERFORM 600-NO-PREV
- 024400 GO TO 420-COMPARE.
- 024500 IF TRAN-CTL IS EQUAL TO PREV-CTL
- 024600 PERFORM 700-MATCH
- 024700 GO TO 420-COMPARE.
- 024800 430-RETURN-SORT.
- 024900 RETURN SORT-WORK AT END
- 025000 MOVE "X" TO END-OF-TRAN.
- 025100 MOVE REC-TYP-SR TO REC-TYP-TC.
- 025200 MOVE SDRP-SR TO SDRP-TC.
- 025300 MOVE ALLOT-PAST-SR TO ALLOT-PAST-TC
- 025400 MOVE LINE-SR TO LINE-TC.
- 025500 IF END-OF-TRAN = "X"
- 025600 MOVE ALL "9" TO TRAN-CTL.
- 025700 440-READ-PREV.
- 025800 READ PREV-FILE AT END
- 025900 MOVE "X" TO END-OF-PREV.
- 026000 MOVE DIC-VA1X TO REC-TYP-PC.
- 026100 MOVE BLM-ADM-U-0003-VA1X TO SDRP-PC.
- 026200 MOVE ALLOT-PAST-VA1X TO ALLOT-PAST-PC.
- 026300 MOVE LIN-NUM-3578-VA1X TO LINE-PC.
- 026400 IF END-OF-PREV = "X"
- 026500 MOVE ALL "9" TO PREV-CTL.
- 026600 500-NO-TRAN.
- 026700 MOVE VA1X-RCD TO VA1Z-RCD.
- 026800 ADD 1 TO VA-CTR.
- 026900 PERFORM 920-WRITE-Z.
- 027000 PERFORM 440-READ-PREV.
- 027100 600-NO-PREV.
- 027200 MOVE SORT-RCD TO VA1Z-RCD.
- 027300 ADD 1 TO VA-CTR.
- 027400 PERFORM 810-BUILD-LIN.
- 027500 PERFORM 820-CHECK-LIN THRU 820-OUT.
- 027600 PERFORM 890-EDIT-DATE.
- 027700 PERFORM 920-WRITE-Z.
- 027800 PERFORM 430-RETURN-SORT.
- 027900 700-MATCH.
- 028000 MOVE VA1X-RCD TO VA1Z-RCD.
- 028100 PERFORM 890-EDIT-DATE.
- 028200 MOVE SORT-RCD TO VA1K-RCD.
- 028300 IF (DATA-1-SR NOT = SPACE) OR
- 028400 (DATA-2-SR NOT = SPACE)
- 028500 PERFORM 850-MOVE-FIELDS
- 028600 PERFORM 810-BUILD-LIN
- 028700 ADD 1 TO VA-CTR
- 028800 PERFORM 920-WRITE-Z.
- 028900 PERFORM 430-RETURN-SORT.
- 029000 PERFORM 440-READ-PREV.
- 029100 810-BUILD-LIN.
- 029200 IF (LIN-NUM-3578-VA1Z NOT NUMERIC) OR
- 029300 (LIN-NUM-3578-VA1Z = "0000")
- 029400 MOVE "9999" TO LIN-NUM-3578-VA1Z.
- 029500 820-CHECK-LIN.
- 029600 IF LIN-NUM-3578-VA1Z NOT = "9999"
- 029700 GO TO 820-OUT.
- 029800 MOVE DIC-VA1Z TO REC-TYP-C.
- 029900 MOVE BLM-ADM-U-0003-VA1Z TO SDRP-C.
- 030000 MOVE ALLOT-PAST-VA1Z TO ALLOT-PAST-C.
- 030100 IF CTL NOT = CTL-SAVE
- 030200 MOVE 0001 TO LAST-LIN-NUM
- 030300 MOVE "0001" TO LIN-NUM-3578-VA1Z ELSE
- 030400 ADD 1 TO LAST-LIN-NUM
- 030500 MOVE LAST-LIN-NUM TO LIN-NUM-3578-VA1Z.
- 030600 MOVE CTL TO CTL-SAVE.
- 030700 820-OUT.
- 030800 EXIT.
- 030900*
- 031000 850-MOVE-FIELDS.
- 031100 IF MTR-TWNSHP-1695-VA1K = SPACES
- 031200 NEXT SENTENCE
- 031300 ELSE
- 031400 IF MTR-TWNSHP-1695-VA1K = "*****"
- 031500 MOVE SPACES TO MTR-TWNSHP-1695-VA1Z
- 031600 ELSE
- 031700 MOVE MTR-TWNSHP-1695-VA1K TO MTR-TWNSHP-1695-VA1Z.
- 031800 IF MTR-RNG-1699-VA1K = SPACES
- 031900 NEXT SENTENCE
- 032000 ELSE
- 032100 IF MTR-RNG-1699-VA1K = "*****"
- 032200 MOVE SPACES TO MTR-RNG-1699-VA1Z
- 032300 ELSE
- 032400 MOVE MTR-RNG-1699-VA1K TO MTR-RNG-1699-VA1Z.
- 032500 IF SEC-SECT-2506-VA1K = SPACES
- 032600 NEXT SENTENCE
- 032700 ELSE
- 032800 IF SEC-SECT-2506-VA1K = "***"
- 032900 MOVE SPACES TO SEC-SECT-2506-VA1Z
- 033000 ELSE
- 033100 MOVE SEC-SECT-2506-VA1K TO SEC-SECT-2506-VA1Z.
- 033200 IF SWA-3507-VA1K = SPACES
- 033300 NEXT SENTENCE
- 033400 ELSE
- 033500 IF SWA-3507-VA1K = "****"
- 033600 MOVE SPACES TO SWA-3507-VA1Z
- 033700 ELSE
- 033800 MOVE SWA-3507-VA1K TO SWA-3507-VA1Z.
- 033900 IF ALIQ-PART-2904-VA1K (1) = SPACES
- 034000 NEXT SENTENCE
- 034100 ELSE
- 034200 IF ALIQ-PART-2904-VA1K (1) = "****"
- 034300 MOVE SPACES TO ALIQ-PART-2904-VA1Z (1)
- 034400 ELSE
- 034500 MOVE ALIQ-PART-2904-VA1K (1) TO ALIQ-PART-2904-VA1Z (1).
- 034600 IF ALIQ-PART-2904-VA1K (2) = SPACES
- 034700 NEXT SENTENCE
- 034800 ELSE
- 034900 IF ALIQ-PART-2904-VA1K (2) = "****"
- 035000 MOVE SPACES TO ALIQ-PART-2904-VA1Z (2)
- 035100 ELSE
- 035200 MOVE ALIQ-PART-2904-VA1K (2) TO ALIQ-PART-2904-VA1Z (2).
- 035300 IF ALIQ-PART-2904-VA1K (3) = SPACES
- 035400 NEXT SENTENCE
- 035500 ELSE
- 035600 IF ALIQ-PART-2904-VA1K (3) = "****"
- 035700 MOVE SPACES TO ALIQ-PART-2904-VA1Z (3)
- 035800 ELSE
- 035900 MOVE ALIQ-PART-2904-VA1K (3) TO ALIQ-PART-2904-VA1Z (3).
- 036000 IF ALIQ-PART-2904-VA1K (4) = SPACES
- 036100 NEXT SENTENCE
- 036200 ELSE
- 036300 IF ALIQ-PART-2904-VA1K (4) = "****"
- 036400 MOVE SPACES TO ALIQ-PART-2904-VA1Z (4)
- 036500 ELSE
- 036600 MOVE ALIQ-PART-2904-VA1K (4) TO ALIQ-PART-2904-VA1Z (4).
- 036700 IF ACR-DU-6520-OWNR-VA1K = SPACES
- 036800 NEXT SENTENCE
- 036900 ELSE
- 037000* IF ACR-DU-6520-OWNR-VA1K = "*****"
- 037100 IF ACR-DU-6520-OWNR-VA1K = "00000"
- 037200 MOVE SPACES TO ACR-DU-6520-OWNR-VA1Z
- 037300 ELSE
- 037400 MOVE ACR-DU-6520-OWNR-VA1K TO ACR-DU-6520-OWNR-VA1Z.
- 037500 IF OWN-TYP-2531-VA1K = SPACES
- 037600 NEXT SENTENCE
- 037700 ELSE
- 037800 IF OWN-TYP-2531-VA1K = "****"
- 037900 MOVE SPACES TO OWN-TYP-2531-VA1Z
- 038000 ELSE
- 038100 MOVE OWN-TYP-2531-VA1K TO OWN-TYP-2531-VA1Z.
- 038200 IF JURIS-2572-VA1K = SPACES
- 038300 NEXT SENTENCE
- 038400 ELSE
- 038500 IF JURIS-2572-VA1K = "****"
- 038600 MOVE SPACES TO JURIS-2572-VA1Z
- 038700 ELSE
- 038800 MOVE JURIS-2572-VA1K TO JURIS-2572-VA1Z.
- 038900 IF MGT-ADM-2570-VA1K = SPACES
- 039000 NEXT SENTENCE
- 039100 ELSE
- 039200 IF MGT-ADM-2570-VA1K = "****"
- 039300 MOVE SPACES TO MGT-ADM-2570-VA1Z
- 039400 ELSE
- 039500 MOVE MGT-ADM-2570-VA1K TO MGT-ADM-2570-VA1Z.
- 039600 IF LAND-TYP-3801-VA1K = SPACES
- 039700 NEXT SENTENCE
- 039800 ELSE
- 039900 IF LAND-TYP-3801-VA1K = "****"
- 040000 MOVE SPACES TO LAND-TYP-3801-VA1Z
- 040100 ELSE
- 040200 MOVE LAND-TYP-3801-VA1K TO LAND-TYP-3801-VA1Z.
- 040300 890-EDIT-DATE.
- 040400 MOVE SPACE TO DATE-MV-SW.
- 040500 MOVE DATA-DATE-6618-VA1Z TO DATE-WORK.
- 040600 PERFORM 900-EDIT-FIELDS.
- 040700 IF DATE-SW NOT = " "
- 040800 PERFORM 910-SWITCH-FIELDS
- 040900 PERFORM 900-EDIT-FIELDS.
- 041000 IF DATE-SW NOT = " "
- 041100 MOVE TODAYS-DATE TO DATA-DATE-6618-VA1Z.
- 041200 IF DATE-MV-SW NOT = " "
- 041300 MOVE MOVED-DATE TO DATA-DATE-6618-VA1Z.
- 041400 900-EDIT-FIELDS.
- 041500 MOVE SPACE TO DATE-SW.
- 041600 IF DW-MM NOT NUMERIC OR
- 041700 DW-MM > "12" OR
- 041800 DW-MM < "01"
- 041900 MOVE "X" TO DATE-SW.
- 042000 IF DW-DD NOT NUMERIC OR
- 042100 DW-DD > "31" OR
- 042200 DW-DD < "01"
- 042300 MOVE "X" TO DATE-SW.
- 042400 IF DW-YY NOT NUMERIC OR
- 042500 DW-YY < "78"
- 042600 MOVE "X" TO DATE-SW.
- 042700 910-SWITCH-FIELDS.
- 042800 MOVE " " TO DATE-MV-SW.
- 042900 IF DW-DD = "78" OR "79" OR "80" OR "81" OR "82"
- 043000 MOVE DW-MM TO MD-MM
- 043100 MOVE DW-DD TO MD-DD
- 043200 MOVE DW-YY TO MD-YY
- 043300 MOVE "X" TO DATE-MV-SW.
- 043400 920-WRITE-Z.
- 043500 MOVE LIN-NUM-3578-VA1Z TO LAST-LIN-NUM.
- 043600 MOVE DIC-VA1Z TO REC-TYP-C.
- 043700 MOVE BLM-ADM-U-0003-VA1Z TO SDRP-C.
- 043800 MOVE ALLOT-PAST-VA1Z TO ALLOT-PAST-C.
- 043900 MOVE CTL TO CTL-SAVE.
- 044000 MOVE SPACE TO OPEN-VA1Z.
- 044100 MOVE "A" TO ACTN-CD-7350-VA1Z.
- 044200 WRITE VA1Z-RCD.
- 044300 400-EXIT.
- 044400 EXIT.
- 044500*
- 044600 990-TERMINATE SECTION.
- 044700 990-PRINT.
- 044800 DISPLAY "VA RCDS"
- 044900 DISPLAY " " VA-CTR.
- 045000 990-CLOSE.
- 045100 CLOSE TRAN-FILE PREV-FILE NEW-FILE.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES215P.
- 000300* VA VERIFICATION LIST
- 000400*
- 000500 AUTHOR. CORA FISCHER.
- 000600 INSTALLATION.
- 000700 DATE-WRITTEN. 7/21/80.
- 000800 DATE-COMPILED.
- 000900 ENVIRONMENT DIVISION.
- 001000 CONFIGURATION SECTION.
- 001100 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001200 OBJECT-COMPUTER. LEVEL-66-ASCII.
- 001300 INPUT-OUTPUT SECTION.
- 001400 FILE-CONTROL.
- 001500 SELECT INPUT-FILE1 ASSIGN TO I1-ES210UD1
- 001600 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001700 SELECT PRINT-FILE ASSIGN TO P1-PRINTER
- 001800 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001900 SELECT SORT-FILE ASSIGN TO S1.
- 002000 DATA DIVISION.
- 002100 SUB-SCHEMA SECTION.
- 002200 DB CODVAL2 WITHIN BLMDIC.
- 002300 FILE SECTION.
- 002400 FD INPUT-FILE1 CODE-SET IS GBCD
- 002500 LABEL RECORDS ARE STANDARD
- 002600 DATA RECORD IS FDR-VA.
- 002700 01 FDR-VA.
- 002800 03 REC-TYPE-3529-VA-I1 PIC X(02).
- 002900 03 FMT-NO-3576-VA-I1 PIC X(01).
- 003000 03 FMT-CD-3579-VA-I1 PIC X(01).
- 003100 03 ADM-UNIT-0003-VA-I1 PIC X(08).
- 003200 03 ALLOT-NUM-0968-VA-I1 PIC X(04).
- 003300 03 PASTURE-NUM-3905-VA-I1 PIC X(02).
- 003400 03 DATA-DT-6618-VA-I1 PIC X(06).
- 003500 03 ACT-CD-7350-VA-I1 PIC X(01).
- 003600 03 MAP-SRC-3540-VA-I1 PIC X(04).
- 003700 03 MTR-MER-CD-1703-VA-I1 PIC X(02).
- 003800 03 LINE-NO-3578-VA-I1 PIC X(04).
- 003900 03 MTR-TWNSHIP-1695-VA-I1 PIC X(05).
- 004000 03 MTR-RNG-1699-VA-I1 PIC X(05).
- 004100 03 SEC-SECT-2506-VA-I1 PIC X(03).
- 004200 03 SWA-3507-VA-I1 PIC X(04).
- 004300 03 ALIQ-PART-2904-VA-I1 PIC X(04) OCCURS 4 TIMES.
- 004400 03 ACR-DU-6520-VA-I1 PIC X(05).
- 004500 03 OWN-TYP-2531-VA-I1 PIC X(04).
- 004600 03 JURIS-2572-VA-I1 PIC X(04).
- 004700 03 MGT-ADM-2570-VA-I1 PIC X(04).
- 004800 03 LAND-TYP-3801-VA-I1 PIC X(04).
- 004900 FD PRINT-FILE CODE-SET IS GBCD
- 005000 LABEL RECORDS ARE STANDARD
- 005100 DATA RECORD IS PRT-REC.
- 005200 01 PRT-REC PIC X(132).
- 005300 SD SORT-FILE DATA RECORDS IS S-KEY1.
- 005400 01 S-KEY1.
- 005500 03 REC-TYPE-3529-VA-S1 PIC X(02).
- 005600 03 FMT-NO-3576-VA-S1 PIC X(01).
- 005700 03 FMT-CD-3579-VA-S1 PIC X(01).
- 005800 03 ADM-UNIT-0003-VA-S1.
- 005900 05 ADM-ST-0003-VA-S1 PIC X(02).
- 006000 05 ADM-DI-0003-VA-S1 PIC X(02).
- 006100 05 ADM-RA-0003-VA-S1 PIC X(02).
- 006200 05 ADM-PU-0003-VA-S1 PIC X(02).
- 006300 03 ALLOT-NUM-0968-VA-S1 PIC X(04).
- 006400 03 PASTURE-NUM-3905-VA-S1 PIC X(02).
- 006500 03 DATA-DT-6618-VA-S1 PIC X(06).
- 006600 03 ACT-CD-7350-VA-S1 PIC X(01).
- 006700 03 MAP-SRC-3540-VA-S1 PIC X(04).
- 006800 03 MTR-MER-CD-1703-VA-S1 PIC X(02).
- 006900 03 LINE-NO-3578-VA-S1 PIC X(04).
- 007000 03 MTR-TWNSHIP-1695-VA-S1.
- 007100 05 NUM-1695-VA-S1 PIC 999V9.
- 007200 05 DIR-1695-VA-S1 PIC X(01).
- 007300 03 MTR-RNG-1699-VA-S1.
- 007400 05 NUM-1699-VA-S1 PIC 999V9.
- 007500 05 DIR-1699-VA-S1 PIC X(01).
- 007600 03 SEC-SECT-2506-VA-S1 PIC X(03).
- 007700 03 SWA-3507-VA-S1 PIC X(04).
- 007800 03 ALIQ-PART-2904-VA-S1 PIC X(04) OCCURS 4 TIMES.
- 007900 03 ACR-DU-6520-VA-S1 PIC X(05).
- 008000 03 OWN-TYP-2531-VA-S1 PIC X(04).
- 008100 03 JURIS-2572-VA-S1 PIC X(04).
- 008200 03 MGT-ADM-2570-VA-S1 PIC X(04).
- 008300 03 LAND-TYP-3801-VA-S1 PIC X(04).
- 008400 WORKING-STORAGE SECTION.
- 008500 77 PAGE-CNT PIC 9(05) VALUE 0.
- 008600 77 VA-CNT PIC 9(07) VALUE 0.
- 008700 77 LINE-CNT PIC 9(02) VALUE 66.
- 008800 01 MONTH-TABLE.
- 008900 03 MO-TAB.
- 009000 05 FILLER PIC X(03) VALUE "JAN".
- 009100 05 FILLER PIC X(03) VALUE "FEB".
- 009200 05 FILLER PIC X(03) VALUE "MAR".
- 009300 05 FILLER PIC X(03) VALUE "APR".
- 009400 05 FILLER PIC X(03) VALUE "MAY".
- 009500 05 FILLER PIC X(03) VALUE "JUN".
- 009600 05 FILLER PIC X(03) VALUE "JUL".
- 009700 05 FILLER PIC X(03) VALUE "AUG".
- 009800 05 FILLER PIC X(03) VALUE "SEP".
- 009900 05 FILLER PIC X(03) VALUE "OCT".
- 010000 05 FILLER PIC X(03) VALUE "NOV".
- 010100 05 FILLER PIC X(03) VALUE "DEC".
- 010200 03 MON REDEFINES MO-TAB PIC X(03) OCCURS 12 TIMES.
- 010300 01 EOF-SWITCH PIC 9 VALUE 0.
- 010400 88 EOF VALUE 1.
- 010500 01 EOR-SWITCH PIC 9 VALUE 0.
- 010600 88 EOR VALUE 1.
- 010700 01 PARAMETER PIC X(04).
- 010800 01 HLD-DT.
- 010900 03 HOLD-DT.
- 011000 05 YR-DT PIC X(02).
- 011100 05 MO-DT PIC 9(02).
- 011200 05 DY-DT PIC X(02).
- 011300 03 INV-HLD.
- 011400 05 INV-NM PIC X(20).
- 011500 05 ST-DIST-CD.
- 011600 07 ST-CD-HLD PIC X(02).
- 011700 07 DI-CD-HLD PIC X(02).
- 011800 03 EXPL-HLD.
- 011900 05 DIST-NM-HLD PIC X(12).
- 012000 03 FUNC-HLD.
- 012100 05 ST-NM-HLD PIC X(10).
- 012200 05 FILLER PIC X(14).
- 012300 COPY DBSTATUS IN TPCOBOLIB.
- 012400 01 HDR-1.
- 012500 03 FILLER PIC X(08) VALUE
- 012600 " DATE: ".
- 012700 03 HDR-MO PIC X(03).
- 012800 03 FILLER PIC X(01) VALUE SPACE.
- 012900 03 HDR-DA PIC X(02).
- 013000 03 FILLER PIC X(04) VALUE ", 19".
- 013100 03 HDR-YR PIC X(02).
- 013200 03 FILLER PIC X(21) VALUE SPACES.
- 013300 03 FILLER PIC X(47) VALUE
- 013400 "US DEPT OF INTERIOR - BUREAU OF LAND MANAGEMENT".
- 013500 03 FILLER PIC X(29) VALUE SPACES.
- 013600 03 FILLER PIC X(07) VALUE
- 013700 "PAGE: ".
- 013800 03 HDR-PG PIC ZZ,ZZ9.
- 013900 03 FILLER PIC X(02) VALUE SPACES.
- 014000 01 HDR-2.
- 014100 03 FILLER PIC X(8) VALUE
- 014200 "STATE: ".
- 014300 03 HDR-ST-CD PIC X(02).
- 014400 03 FILLER PIC X(04) VALUE SPACES.
- 014500 03 HDR-ST-NM PIC X(10).
- 014600 03 FILLER PIC X(30) VALUE SPACES.
- 014700 03 FILLER PIC X(25) VALUE
- 014800 "ECOLOGICAL SITE INVENTORY".
- 014900 03 FILLER PIC X(35) VALUE SPACES.
- 015000 03 FILLER PIC X(18) VALUE
- 015100 "PROGRAM: ES215P ".
- 015200 01 HDR-3.
- 015300 03 FILLER PIC X(08) VALUE
- 015400 " DI: ".
- 015500 03 HDR-DIST-CD PIC X(02).
- 015600 03 FILLER PIC X(04) VALUE SPACES.
- 015700 03 HDR-DIST-NM PIC X(25).
- 015800 03 FILLER PIC X(79) VALUE SPACES.
- 015900 03 FILLER PIC X(14) VALUE
- 016000 "PCN: SV215P ".
- 016100 01 HDR-4.
- 016200 03 FILLER PIC X(08) VALUE
- 016300 " INV: ".
- 016400 03 HDR-INV-CD PIC X(04).
- 016500 03 FILLER PIC X(02) VALUE SPACES.
- 016600 03 HDR-INV-NM PIC X(25).
- 016700 03 FILLER PIC X(16) VALUE SPACES.
- 016800 03 HDR-REC-TYPE PIC X(02).
- 016900 03 FILLER PIC X(18) VALUE
- 017000 " VERIFICATION LIST".
- 017100 03 FILLER PIC X(57) VALUE SPACES.
- 017200 01 HDR-5-VA.
- 017300 03 FILLER PIC X(52) VALUE
- 017400 "(1-2) (3) (4) (5) (6) (7) (8) (9)".
- 017500 03 FILLER PIC X(08) VALUE SPACES.
- 017600 03 FILLER PIC X(51) VALUE
- 017700 "(10) (11) (12) (13) NE4 NW4(14)SW4 SE4 (15) ".
- 017800 03 FILLER PIC X(21) VALUE
- 017900 "(16) (17) (18) (19)".
- 018000 01 HDR-6-VA.
- 018100 03 FILLER PIC X(20) VALUE
- 018200 " REC ADMIN UNIT".
- 018300 03 FILLER PIC X(15) VALUE SPACES.
- 018400 03 FILLER PIC X(36) VALUE
- 018500 "DATE ACT MAP LINE TWP RANGE".
- 018600 03 FILLER PIC X(08) VALUE SPACES.
- 018700 03 FILLER PIC X(41) VALUE
- 018800 "SWA NNSS NNSS NNSS NNSS SURF FED ".
- 018900 03 FILLER PIC X(12) VALUE
- 019000 "SUR ONLY TYP".
- 019100 01 HDR-7-VA.
- 019200 03 FILLER PIC X(54) VALUE
- 019300 "TYPE ST DI RA PU ALLOT PAST YYMMDD CD SRC MER ".
- 019400 03 FILLER PIC X(51) VALUE
- 019500 "NUM NUM FD NUM FD SEC NUM EWWE EWWE EWWE EWWE ".
- 019600 03 FILLER PIC X(27) VALUE
- 019700 "ACRES OWNR JURIS ADMIN LND".
- 019800 01 HDR-8-VA.
- 019900 03 FILLER PIC X(53) VALUE
- 020000 " 1-4 5-6 7-8 9-10 11-2 13-16 17-8 19-24 25 26-9 30 ".
- 020100 03 FILLER PIC X(52) VALUE
- 020200 "32-35 36-40 41-45 46-48 49-52 53-6 57-60 61-4 65-8 ".
- 020300 03 FILLER PIC X(27) VALUE
- 020400 "69-73 74-7 78-81 82-85 86-9".
- 020500 01 HDR-9-VA.
- 020600 03 FILLER PIC X(53) VALUE
- 020700 "XXXX XX XX XX XX XXXX XX XXXXXX X XXXX XX ".
- 020800 03 FILLER PIC X(52) VALUE
- 020900 "9999 999.9X 999.9X 999 XXXX XXXX XXXX XXXX XXXX ".
- 021000 03 FILLER PIC X(27) VALUE
- 021100 "99999 XXXX XXXX XXXX XXXX".
- 021200 01 HDR-10-DET-VA.
- 021300 03 REC-TYPE-3529-VA-P1 PIC X(02).
- 021400 03 FMT-NO-3576-VA-P1 PIC X(01).
- 021500 03 FMT-CD-3579-VA-P1 PIC X(01).
- 021600 03 FILLER PIC X(01) VALUE SPACE.
- 021700 03 ADM-ST-0003-VA-P1 PIC X(02).
- 021800 03 FILLER PIC X(02) VALUE SPACES.
- 021900 03 ADM-DI-0003-VA-P1 PIC X(02).
- 022000 03 FILLER PIC X(03) VALUE SPACES.
- 022100 03 ADM-RA-0003-VA-P1 PIC X(02).
- 022200 03 FILLER PIC X(03) VALUE SPACES.
- 022300 03 ADM-PU-0003-VA-P1 PIC X(02).
- 022400 03 FILLER PIC X(02) VALUE SPACES.
- 022500 03 ALLOT-NUM-0968-VA-P1 PIC X(04).
- 022600 03 FILLER PIC X(03) VALUE SPACES.
- 022700 03 PASTURE-NUM-3905-VA-P1 PIC X(02).
- 022800 03 FILLER PIC X(02) VALUE SPACES.
- 022900 03 DATA-DT-6618-VA-P1 PIC X(06).
- 023000 03 FILLER PIC X(02) VALUE SPACES.
- 023100 03 ACT-CD-7350-VA-P1 PIC X(01).
- 023200 03 FILLER PIC X(01) VALUE SPACE.
- 023300 03 MAP-SRC-3540-VA-P1 PIC X(04).
- 023400 03 FILLER PIC X(02) VALUE SPACES.
- 023500 03 MTR-MER-CD-1703-VA-P1 PIC X(02).
- 023600 03 FILLER PIC X(01) VALUE SPACE.
- 023700 03 LINE-NO-3578-VA-P1 PIC 9(04).
- 023800 03 FILLER PIC X(01) VALUE SPACE.
- 023900 03 MTR-TWNSHIP-1695-VA-P1.
- 024000 05 NUM-1695-VA-P1 PIC 999.9.
- 024100 05 DIR-1695-VA-P1 PIC X(01).
- 024200 03 FILLER PIC X(01) VALUE SPACE.
- 024300 03 MTR-RNG-1699-VA-P1.
- 024400 05 NUM-1699-VA-P1 PIC 999.9.
- 024500 05 DIR-1699-VA-P1 PIC X(01).
- 024600 03 FILLER PIC X(02) VALUE SPACES.
- 024700 03 SEC-SECT-2506-VA-P1 PIC X(03).
- 024800 03 FILLER PIC X(02) VALUE SPACES.
- 024900 03 SWA-3507-VA-P1 PIC X(04).
- 025000 03 FILLER PIC X(02) VALUE SPACES.
- 025100 03 ALIQ-PART1-2904-VA-P1 PIC X(04).
- 025200 03 FILLER PIC X(01) VALUE SPACE.
- 025300 03 ALIQ-PART2-2904-VA-P1 PIC X(04).
- 025400 03 FILLER PIC X(02) VALUE SPACES.
- 025500 03 ALIQ-PART3-2904-VA-P1 PIC X(04).
- 025600 03 FILLER PIC X(01) VALUE SPACE.
- 025700 03 ALIQ-PART4-2904-VA-P1 PIC X(04).
- 025800 03 FILLER PIC X(01) VALUE SPACE.
- 025900 03 ACR-DU-6520-VA-P1 PIC 9(05).
- 026000 03 FILLER PIC X(01) VALUE SPACE.
- 026100 03 OWN-TYP-2531-VA-P1 PIC X(04).
- 026200 03 FILLER PIC X(01) VALUE SPACE.
- 026300 03 JURIS-2572-VA-P1 PIC X(04).
- 026400 03 FILLER PIC X(02) VALUE SPACES.
- 026500 03 MGT-ADM-2570-VA-P1 PIC X(04).
- 026600 03 FILLER PIC X(02) VALUE SPACES.
- 026700 03 LAND-TYP-3801-VA-P1 PIC X(04).
- 026800 PROCEDURE DIVISION.
- 026900 START-SORT SECTION.
- 027000 100-SORT.
- 027100 SORT SORT-FILE ON ASCENDING REC-TYPE-3529-VA-S1
- 027200 FMT-NO-3576-VA-S1 FMT-CD-3579-VA-S1 ADM-UNIT-0003-VA-S1
- 027300 ALLOT-NUM-0968-VA-S1 PASTURE-NUM-3905-VA-S1
- 027400 SWA-3507-VA-S1 MTR-MER-CD-1703-VA-S1
- 027500 MTR-RNG-1699-VA-S1 MTR-TWNSHIP-1695-VA-S1
- 027600 SEC-SECT-2506-VA-S1
- 027700 INPUT PROCEDURE PRE-SORT
- 027800 OUTPUT PROCEDURE POST-SORT.
- 027900 200-END-SECTION.
- 028000 FINISH DIC-DE.
- 028100 DISPLAY "VA-CNT" VA-CNT.
- 028200 CLOSE PRINT-FILE.
- 028300 STOP RUN.
- 028400 PRE-SORT SECTION.
- 028500 300-HSKPNG.
- 028600 OPEN INPUT INPUT-FILE1.
- 028700 MOVE SPACES TO S-KEY1.
- 028800 400-MAIN.
- 028900 PERFORM 500-RD-FILE THRU 600-EXIT-RD UNTIL EOF.
- 029000 CLOSE INPUT-FILE1.
- 029100 GO TO 600-EXIT-RD.
- 029200 500-RD-FILE.
- 029300 READ INPUT-FILE1 AT END MOVE 1 TO EOF-SWITCH.
- 029400 IF (EOF-SWITCH = 1) GO TO 600-EXIT-RD.
- 029500 ADD 1 TO VA-CNT.
- 029600 MOVE FDR-VA TO S-KEY1.
- 029700 RELEASE S-KEY1.
- 029800 600-EXIT-RD.
- 029900 EXIT.
- 030000 POST-SORT SECTION.
- 030100 3050-RET-HSKPNG.
- 030200 OPEN OUTPUT PRINT-FILE.
- 030300 ACCEPT PARAMETER.
- 030400 ACCEPT HOLD-DT FROM DATE.
- 030500 MOVE YR-DT TO HDR-YR.
- 030600 MOVE MON(MO-DT) TO HDR-MO.
- 030700 MOVE DY-DT TO HDR-DA.
- 030800 READY DIC-DE.
- 030900 PERFORM 4000-VALIDATE-INV THRU 4050-EXIT-STDI.
- 031000 RETURN SORT-FILE AT END MOVE 1 TO EOR-SWITCH.
- 031100 3060-MAIN-DRIVER.
- 031200 PERFORM 4300-PRT-DET THRU 4360-EXIT-RET UNTIL EOR.
- 031300 GO TO 5000-DUMMY.
- 031400 4300-PRT-DET.
- 031500 IF LINE-CNT > 50
- 031600 PERFORM 4200-PRT-HDNG.
- 031700 MOVE REC-TYPE-3529-VA-S1 TO REC-TYPE-3529-VA-P1.
- 031800 MOVE FMT-NO-3576-VA-S1 TO FMT-NO-3576-VA-P1.
- 031900 MOVE FMT-CD-3579-VA-S1 TO FMT-CD-3579-VA-P1.
- 032000 MOVE ADM-ST-0003-VA-S1 TO ADM-ST-0003-VA-P1.
- 032100 MOVE ADM-DI-0003-VA-S1 TO ADM-DI-0003-VA-P1.
- 032200 MOVE ADM-RA-0003-VA-S1 TO ADM-RA-0003-VA-P1.
- 032300 MOVE ADM-PU-0003-VA-S1 TO ADM-PU-0003-VA-P1.
- 032400 MOVE ALLOT-NUM-0968-VA-S1 TO ALLOT-NUM-0968-VA-P1.
- 032500 MOVE PASTURE-NUM-3905-VA-S1 TO PASTURE-NUM-3905-VA-P1.
- 032600 MOVE DATA-DT-6618-VA-S1 TO DATA-DT-6618-VA-P1.
- 032700 MOVE ACT-CD-7350-VA-S1 TO ACT-CD-7350-VA-P1.
- 032800 MOVE MAP-SRC-3540-VA-S1 TO MAP-SRC-3540-VA-P1.
- 032900 MOVE MTR-MER-CD-1703-VA-S1 TO MTR-MER-CD-1703-VA-P1.
- 033000 MOVE LINE-NO-3578-VA-S1 TO LINE-NO-3578-VA-P1.
- 033100 MOVE NUM-1695-VA-S1 TO NUM-1695-VA-P1.
- 033200 MOVE DIR-1695-VA-S1 TO DIR-1695-VA-P1.
- 033300 MOVE NUM-1699-VA-S1 TO NUM-1699-VA-P1.
- 033400 MOVE DIR-1699-VA-S1 TO DIR-1699-VA-P1.
- 033500 MOVE SEC-SECT-2506-VA-S1 TO SEC-SECT-2506-VA-P1.
- 033600 MOVE SWA-3507-VA-S1 TO SWA-3507-VA-P1.
- 033700 MOVE ALIQ-PART-2904-VA-S1 (1) TO ALIQ-PART1-2904-VA-P1.
- 033800 MOVE ALIQ-PART-2904-VA-S1 (2) TO ALIQ-PART2-2904-VA-P1.
- 033900 MOVE ALIQ-PART-2904-VA-S1 (3) TO ALIQ-PART3-2904-VA-P1.
- 034000 MOVE ALIQ-PART-2904-VA-S1 (4) TO ALIQ-PART4-2904-VA-P1.
- 034100 MOVE ACR-DU-6520-VA-S1 TO ACR-DU-6520-VA-P1.
- 034200 MOVE OWN-TYP-2531-VA-S1 TO OWN-TYP-2531-VA-P1.
- 034300 MOVE JURIS-2572-VA-S1 TO JURIS-2572-VA-P1.
- 034400 MOVE MGT-ADM-2570-VA-S1 TO MGT-ADM-2570-VA-P1.
- 034500 MOVE LAND-TYP-3801-VA-S1 TO LAND-TYP-3801-VA-P1.
- 034600 WRITE PRT-REC FROM HDR-10-DET-VA AFTER ADVANCING 2 LINES.
- 034700 ADD 2 TO LINE-CNT.
- 034800 4350-RET-SORT.
- 034900 RETURN SORT-FILE AT END MOVE 1 TO EOR-SWITCH.
- 035000 IF (EOR-SWITCH = 1) GO TO 4360-EXIT-RET.
- 035100 4360-EXIT-RET.
- 035200 EXIT.
- 035300 4000-VALIDATE-INV.
- 035400 MOVE PARAMETER TO DE-CD-8822-DEC HDR-INV-CD.
- 035500 MOVE 3940 TO DE-NO-8801-DEC.
- 035600 FIND ANY CODE-DEC.
- 035700 MOVE DB-STATUS TO DB-STAT.
- 035800 IF NOT OK
- 035900 MOVE "UNKNOWN" TO HDR-ST-NM HDR-DIST-NM HDR-INV-NM
- 036000 GO TO 4050-EXIT-STDI.
- 036100 GET CODE-DEC.
- 036200 MOVE DB-STATUS TO DB-STAT.
- 036300 IF NOT OK
- 036400 DISPLAY "ES115PBD DIDN'T GET INVN"
- 036500 DISPLAY DB-STAT
- 036600 GO TO 4050-EXIT-STDI.
- 036700 MOVE DE-CD-NAM-8823-DEC TO INV-HLD.
- 036800 MOVE INV-NM TO HDR-INV-NM.
- 036900 4005-VALIDATE-ST.
- 037000 MOVE ST-CD-HLD TO DE-CD-8822-DEC HDR-ST-CD.
- 037100 MOVE 0003 TO DE-NO-8801-DEC.
- 037200 FIND ANY CODE-DEC.
- 037300 MOVE DB-STATUS TO DB-STAT.
- 037400 IF NOT OK
- 037500 MOVE "UNKNOWN" TO HDR-ST-NM
- 037600 GO TO 4008-EXIT-ST.
- 037700 GET CODE-DEC.
- 037800 MOVE DB-STATUS TO DB-STAT.
- 037900 IF NOT OK
- 038000 DISPLAY "ES115PBD 3 DIDN'T GET ST"
- 038100 DISPLAY "ES115PBD 4 " DB-STAT
- 038200 GO TO 4008-EXIT-ST.
- 038300 MOVE DE-CD-NAM-8823-DEC TO FUNC-HLD.
- 038400 MOVE ST-NM-HLD TO HDR-ST-NM.
- 038500 4008-EXIT-ST.
- 038600 EXIT.
- 038700 4010-VALIDATE-STDI.
- 038800 MOVE ST-DIST-CD TO DE-CD-8822-DEC.
- 038900 MOVE DI-CD-HLD TO HDR-DIST-CD.
- 039000 MOVE 0003 TO DE-NO-8801-DEC.
- 039100 FIND ANY CODE-DEC.
- 039200 MOVE DB-STATUS TO DB-STAT.
- 039300 IF NOT OK
- 039400 MOVE "UNKNOWN" TO HDR-DIST-NM
- 039500 GO TO 4050-EXIT-STDI.
- 039600 GET CODE-DEC.
- 039700 MOVE DB-STATUS TO DB-STAT.
- 039800 IF NOT OK
- 039900 DISPLAY "ES115PBD 5 DIDN'T GET STDI"
- 040000 DISPLAY "ES115PBD 6 " DB-STAT
- 040100 GO TO 4050-EXIT-STDI.
- 040200 FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
- 040300 MOVE DB-STATUS TO DB-STAT.
- 040400 IF NOT OK
- 040500 MOVE "UNKNOWN" TO HDR-DIST-NM
- 040600 GO TO 4050-EXIT-STDI.
- 040700 GET CODE-EXPL-DECE.
- 040800 MOVE DB-STATUS TO DB-STAT.
- 040900 IF NOT OK
- 041000 DISPLAY "ES115PBD 7 DIDN'T GET DIST"
- 041100 DISPLAY "ES115PBD 8 " DB-STAT
- 041200 GO TO 4050-EXIT-STDI.
- 041300 MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HLD.
- 041400 MOVE DIST-NM-HLD TO HDR-DIST-NM.
- 041500 4050-EXIT-STDI.
- 041600 EXIT.
- 041700 4200-PRT-HDNG.
- 041800 MOVE "VA" TO HDR-REC-TYPE.
- 041900 ADD 1 TO PAGE-CNT.
- 042000 MOVE PAGE-CNT TO HDR-PG.
- 042100 WRITE PRT-REC FROM HDR-1 AFTER ADVANCING PAGE.
- 042200 WRITE PRT-REC FROM HDR-2 AFTER ADVANCING 1 LINES.
- 042300 WRITE PRT-REC FROM HDR-3 AFTER ADVANCING 1 LINES.
- 042400 WRITE PRT-REC FROM HDR-4 AFTER ADVANCING 1 LINES.
- 042500 WRITE PRT-REC FROM HDR-5-VA AFTER ADVANCING 2 LINES.
- 042600 WRITE PRT-REC FROM HDR-6-VA AFTER ADVANCING 1 LINES.
- 042700 WRITE PRT-REC FROM HDR-7-VA AFTER ADVANCING 1 LINES.
- 042800 WRITE PRT-REC FROM HDR-8-VA AFTER ADVANCING 1 LINES.
- 042900 WRITE PRT-REC FROM HDR-9-VA AFTER ADVANCING 1 LINES.
- 043000 MOVE SPACES TO PRT-REC.
- 043100 WRITE PRT-REC AFTER ADVANCING 1 LINES.
- 043200 MOVE 10 TO LINE-CNT.
- 043300 4350-END-RET.
- 043400 EXIT.
- 043500 DUMMY-SECTION.
- 043600 5000-DUMMY.
- 043700 EXIT.
- 043800 END-OF-JOB.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES220E.
- 000300* VA EDIT UPDATE
- 000400*
- 000500 AUTHOR. FRANK WILEY.
- 000600 DATE-WRITTEN. 05 SEP 79.
- 000700 DATE-COMPILED.
- 000800 ENVIRONMENT DIVISION.
- 000900 CONFIGURATION SECTION.
- 001000 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001100 OBJECT-COMPUTER. LEVEL-66-ASCII, SEQUENCE IS EBCDIC.
- 001200 INPUT-OUTPUT SECTION.
- 001300 FILE-CONTROL.
- 001400 SELECT VA1Z-OUT ASSIGN TO D1
- 001500 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001600 SELECT VA1K-IN ASSIGN TO I1
- 001700 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001800 SELECT PRINT-FILE ASSIGN TO P1-PRINTER
- 001900 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002000 DATA DIVISION.
- 002100 SUB-SCHEMA SECTION.
- 002200 DB CODVAL2 WITHIN BLMDIC.
- 002300 FILE SECTION.
- 002400 FD VA1Z-OUT
- 002500 CODE-SET IS GBCD
- 002600 LABEL RECORD IS STANDARD.
- 002700 01 VA1Z-RCD PIC X(90).
- 002800 FD VA1K-IN
- 002900 CODE-SET IS GBCD
- 003000 LABEL RECORDS ARE STANDARD.
- 003100 01 VA1K-RCD.
- 003200 03 REC-TYP-I1 PIC XXXX.
- 003300 03 SDRP-I1 PIC X(8).
- 003400 03 FILLER PIC X(78).
- 003500 FD PRINT-FILE
- 003600 CODE-SET IS GBCD
- 003700 LABEL RECORDS ARE STANDARD
- 003800 DATA RECORD IS PRINT-RCD.
- 003900 01 PRINT-RCD PIC X(132).
- 004000 WORKING-STORAGE SECTION.
- 004100 77 1ST-TIME-FLG PIC 9(01) COMP-4 VALUE ZERO.
- 004200 77 AD-ST-H PIC X(02).
- 004300 77 DUPE-1-HLD PIC X(14) VALUE SPACES.
- 004400 77 DUPE-2-HLD PIC X(4) VALUE SPACES.
- 004500 77 ERR-CNT PIC 9(5) VALUE ZERO.
- 004600 77 ERROR-SW COMP-4 PIC 9 VALUE ZERO.
- 004700 77 HDR-SW1 COMP-4 PIC 9 VALUE ZERO.
- 004800 77 HDR-SW2 COMP-4 PIC 9 VALUE ZERO.
- 004900 77 HDR-SW3 COMP-4 PIC 9 VALUE ZERO.
- 005000 77 LINE-CNT COMP-4 PIC 99 VALUE ZERO.
- 005100 77 PAGE-NO COMP-4 PIC 9(6) VALUE ZERO.
- 005200 77 PAGE-SW COMP-4 PIC 9 VALUE 1.
- 005300 77 PROCESS-SW COMP-4 PIC 9 VALUE ZERO.
- 005400 77 SS1A PIC 9(01) COMP-4 VALUE 1.
- 005500 77 SUB COMP-4 PIC 9 VALUE 1.
- 005600 77 TOTL-SW COMP-4 PIC 9 VALUE ZERO.
- 005700 01 HOLD-AREA.
- 005800 03 ALLOT-NUM-HOLD PIC X(4).
- 005900 03 BLM-ADM-HOLD.
- 006000 05 ST-HOLD PIC XX.
- 006100 05 DT-HOLD PIC XX.
- 006200 05 RA-HOLD PIC XX.
- 006300 05 PLU-HOLD PIC XX.
- 006400 03 DATE-H.
- 006500 05 YEAR-H PIC X(02).
- 006600 05 MON-H PIC 9(02).
- 006700 05 DAY-H PIC X(02).
- 006800 03 DE-CD-EXPLN-8827-DECE-H.
- 006900 05 DE-H PIC 9(04).
- 007000 05 FILLER PIC X(36).
- 007100 03 DE-EXT-CD-NAM-8825-DEEE-H.
- 007200 05 ALL-SEC PIC X(01).
- 007300 05 1-SEC PIC X(01) OCCURS 36 TIMES.
- 007400 05 FILLER PIC X(15).
- 007500 03 DIST-H PIC XX.
- 007600 03 EXPL-HOLD.
- 007700 05 DIST-NAME PIC X(10).
- 007800 05 FILLER PIC X.
- 007900 05 RA-NAME PIC X(12).
- 008000 05 FILLER PIC X.
- 008100 05 PLU-NAME PIC X(15).
- 008200 05 FILLER PIC X.
- 008300 03 FUNC-HOLD.
- 008400 05 STATE-NAME PIC X(10).
- 008500 05 FILLER PIC X(14).
- 008600 03 MAP-SRC-HOLD PIC X(4).
- 008700 03 MER-TWP-RNG-H.
- 008800 05 MER-H PIC X(02).
- 008900 05 TWP-RNG-H PIC X(10).
- 009000 03 MTR-MER-CD-HOLD PIC XX.
- 009100 03 PASTURE-NUM-HOLD PIC XX.
- 009200 01 TABLE-AREA.
- 009300 03 DE-V.
- 009400 05 FILLER PIC 9(12) VALUE 999999999999.
- 009500 05 FILLER PIC 9(12) VALUE 999999999999.
- 009600 03 DE-T REDEFINES DE-V PIC 9(04) OCCURS 6 TIMES.
- 009700 03 MO-V PIC X(36) VALUE "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOV
- 009800- "DEC".
- 009900 03 MO-T REDEFINES MO-V PIC X(03) OCCURS 12 TIMES.
- 010000 COPY DBSTATUS OF TPCOBOLIB.
- 010100 01 RECORD-VA1D.
- 010200 03 KEY-VA1D.
- 010300 05 DIC-VA1D.
- 010400 07 REC-TYP PIC X(2).
- 010500 07 FMT-NUM PIC X(1).
- 010600 07 FMT-CD PIC X(1).
- 010700 03 BLM-ADM-U-0003.
- 010800 05 BLM-ADM-4.
- 010900 07 BLM-ADM-3.
- 011000 09 BLM-ADM-2.
- 011100 11 AD-ST-IN PIC XX.
- 011200 11 BLM-ADM-DIST PIC XX.
- 011300 09 BLM-ADM-RA PIC XX.
- 011400 07 BLM-ADM-PLU PIC XX.
- 011500 05 ALLOT-NUM PIC X(4).
- 011600 05 PASTURE-NUM PIC X(2).
- 011700 05 DATA-DATE.
- 011800 07 DATA-DATE-YY PIC X(2).
- 011900 07 DATA-DATE-MM PIC X(2).
- 012000 07 DATA-DATE-DD PIC X(2).
- 012100 05 ACTN-CD PIC X(1).
- 012200 05 MAP-SRC-IN PIC X(4).
- 012300 05 MTR-MER-CD-IN PIC X(2).
- 012400 05 LIN-NUM PIC X(4).
- 012500 03 TWP-RNG-IN.
- 012600 05 MTR-TWNSHP-IN.
- 012700 07 TWNSHIP-3 PIC X(3).
- 012800 07 TWNSHIP-2 PIC XX.
- 012900 05 MTR-RNG-IN.
- 013000 07 RNGE-3 PIC X(3).
- 013100 07 RNGE-2 PIC XX.
- 013200 03 SEC-SECT-IN.
- 013300 05 FILLER PIC X(01).
- 013400 05 SEC-C2-3-IN PIC 9(02).
- 013500 03 SWA.
- 013600 05 SWA-CD PIC X(1).
- 013700 05 SWA-NUM PIC X(3).
- 013800 03 ALIQ-PART.
- 013900 05 ALIQ-PART-QRT OCCURS 4 TIMES.
- 014000 07 ALIQ-1 PIC X.
- 014100 07 ALIQ-2 PIC X.
- 014200 07 ALIQ-3 PIC X.
- 014300 07 ALIQ-4 PIC X.
- 014400 03 ACR-DU-OWNR PIC X(5).
- 014500 03 OWN-TYP.
- 014600 05 OWN-TYP-2.
- 014700 07 OWN-TYP-1 PIC X.
- 014800 07 FILLER PIC X.
- 014900 05 FILLER PIC XX.
- 015000 03 JURIS PIC X(4).
- 015100 03 MGT-ADM PIC X(4).
- 015200 03 LAND-TYP PIC X(4).
- 015300 03 FILLER PIC X.
- 015400 01 ERR-LINE.
- 015500 03 FILLER PIC X(12) VALUE " THERE WERE ".
- 015600 03 CNT-ERRS PIC ZZ,ZZZ.
- 015700 03 FILLER PIC X(18) VALUE " VA ERROR RECORDS ".
- 015800 03 FILLER PIC X(9) VALUE "PRINTED. ".
- 015900 01 HDR-1.
- 016000 03 FILLER PIC X(24) VALUE " PCN ES220EP1 AS OF ".
- 016100 03 DD PIC X(02).
- 016200 03 FILLER PIC X VALUE SPACE.
- 016300 03 MMM PIC X(03).
- 016400 03 FILLER PIC X VALUE SPACE.
- 016500 03 YY PIC X(02).
- 016600 03 FILLER PIC X(09) VALUE SPACES.
- 016700 03 FILLER PIC X(48) VALUE
- 016800 "USDI- BUR OF LAND MGT ECOLOGICAL SITE INVENTORY".
- 016900 03 FILLER PIC X(29) VALUE SPACES.
- 017000 03 FILLER PIC X(7) VALUE "PAGE ".
- 017100 03 PAGE-CNT PIC Z(06).
- 017200 01 HDR-2.
- 017300 03 FILLER PIC X(17) VALUE SPACES.
- 017400 03 FILLER PIC X(8) VALUE "STATE ".
- 017500 03 ST-HDR PIC X(15).
- 017600 03 FILLER PIC X(16) VALUE SPACES.
- 017700 03 FILLER PIC X(7) VALUE "DIST ".
- 017800 03 DIST-HDR PIC X(15).
- 017900 03 FILLER PIC X(15) VALUE SPACES.
- 018000 03 FILLER PIC X(22) VALUE "VA EDIT ERROR LISTING".
- 018100 03 FILLER PIC X(17) VALUE SPACES.
- 018200 01 HDR-3.
- 018300 03 FILLER PIC X(40) VALUE
- 018400 " REC TYP ST DIST RA".
- 018500 03 FILLER PIC X(40) VALUE
- 018600 " PLU ALLOT PASTURE ".
- 018700 03 FILLER PIC X(40) VALUE
- 018800 " DATE ACTN MAP SOURCE ".
- 018900 03 FILLER PIC X(12) VALUE SPACES.
- 019000 01 HDR-4.
- 019100 03 FILLER PIC X(9) VALUE SPACES.
- 019200 03 FILLER PIC X(43) VALUE
- 019300 "1-4 5-6 7-8 9-10 11-12".
- 019400 03 FILLER PIC X(44) VALUE
- 019500 " 13-16 17-18 19-24 25".
- 019600 03 FILLER PIC X(36) VALUE
- 019700 " 26-29 ".
- 019800 01 HDR-5.
- 019900 03 FILLER PIC X(9) VALUE SPACES.
- 020000 03 FILLER PIC X(42) VALUE
- 020100 "XXXX XX XX XX XX".
- 020200 03 FILLER PIC X(45) VALUE
- 020300 " XXXX XX XXXXXX X".
- 020400 03 FILLER PIC X(36) VALUE
- 020500 " XXXX ".
- 020600 01 HDR-6.
- 020700 03 FILLER PIC X(40) VALUE
- 020800 "MERIDIAN LINE TWNSHIP RNGE SECT ".
- 020900 03 FILLER PIC X(40) VALUE
- 021000 "SWA NE 1/4 NW 1/4 SW 1/4 ".
- 021100 03 FILLER PIC X(40) VALUE
- 021200 "SE 1/4 ACRES SURF OWN JURIS ADMIN ".
- 021300 03 FILLER PIC X(12) VALUE
- 021400 " LAND TYPE ".
- 021500 01 HDR-7.
- 021600 03 FILLER PIC X(40) VALUE
- 021700 " 30-31 32-35 36-40 41-45 46-48 4".
- 021800 03 FILLER PIC X(40) VALUE
- 021900 "9-52 53-56 57-60 61-64 ".
- 022000 03 FILLER PIC X(40) VALUE
- 022100 " 65-68 69-73 74-77 78-81 82-85 ".
- 022200 03 FILLER PIC X(12) VALUE
- 022300 " 86-89 ".
- 022400 01 HDR-8.
- 022500 03 FILLER PIC X(40) VALUE
- 022600 " XX XXXX XXX XX XXX XX XXX ".
- 022700 03 FILLER PIC X(40) VALUE
- 022800 "XXXX X X X X X X X X X X X X ".
- 022900 03 FILLER PIC X(40) VALUE
- 023000 "X X X X XXXXX XXXX XXXX XXXX ".
- 023100 03 FILLER PIC X(12) VALUE
- 023200 " XXXX ".
- 023300 01 PRINT-1 VALUE SPACES.
- 023400 03 FILLER PIC X(9).
- 023500 03 REC-TYP-P PIC X(4).
- 023600 03 FILLER PIC X(7).
- 023700 03 AD-ST-P PIC XX.
- 023800 03 FILLER PIC X(8).
- 023900 03 BLM-ADM-DIST-P PIC XX.
- 024000 03 FILLER PIC X(6).
- 024100 03 BLM-ADM-RA-P PIC XX.
- 024200 03 FILLER PIC X(9).
- 024300 03 BLM-ADM-PLU-P PIC XX.
- 024400 03 FILLER PIC X(9).
- 024500 03 ALLOT-NUM-P PIC X(4).
- 024600 03 FILLER PIC X(9).
- 024700 03 PASTURE-NUM-P PIC XX.
- 024800 03 FILLER PIC X(7).
- 024900 03 DATA-DATE-P PIC X(6).
- 025000 03 FILLER PIC X(7).
- 025100 03 ACTN-CD-P PIC X.
- 025200 03 FILLER PIC X(10).
- 025300 03 MAP-SOURCE-P PIC X(4).
- 025400 03 FILLER PIC X(13).
- 025500 03 FILLER PIC X(9).
- 025600 01 PRINT-2 VALUE SPACES.
- 025700 03 FILLER PIC X(9).
- 025800 03 RCD-ERR PIC X(4).
- 025900 03 FILLER PIC X(7).
- 026000 03 ST-ERR PIC XX.
- 026100 03 FILLER PIC X(8).
- 026200 03 DT-ERR PIC XX.
- 026300 03 FILLER PIC X(6).
- 026400 03 RA-ERR PIC XX.
- 026500 03 FILLER PIC X(9).
- 026600 03 PLU-ERR PIC XX.
- 026700 03 FILLER PIC X(9).
- 026800 03 ALLOT-ERR PIC X(4).
- 026900 03 FILLER PIC X(9).
- 027000 03 PASTURE-ERR PIC XX.
- 027100 03 FILLER PIC X(31).
- 027200 03 MAP-ERR PIC X(4).
- 027300 03 FILLER PIC X(13).
- 027400 03 MERID-ERR PIC XX.
- 027500 03 FILLER PIC X(7) .
- 027600 01 PRINT-3.
- 027700 03 FILLER PIC X(3) VALUE SPACES.
- 027800 03 MERIDIAN-P PIC XX.
- 027900 03 FILLER PIC X(4) VALUE SPACES.
- 028000 03 LIN-NUM-P PIC X(4).
- 028100 03 FILLER PIC X(2) VALUE SPACES.
- 028200 03 TWNSHIP-P PIC X(3).
- 028300 03 FILLER PIC X VALUE ".".
- 028400 03 TWNSHIP-P1 PIC XX.
- 028500 03 FILLER PIC XX VALUE SPACES.
- 028600 03 RNGE-P PIC XXX.
- 028700 03 FILLER PIC X VALUE ".".
- 028800 03 RNGE-P1 PIC XX.
- 028900 03 FILLER PIC XXX VALUE SPACES.
- 029000 03 SECT-P PIC XXX.
- 029100 03 FILLER PIC X(5) VALUE SPACES.
- 029200 03 SWA-P PIC X(4).
- 029300 03 FILLER PIC XX VALUE SPACES.
- 029400 03 FILLER PIC X VALUE ".".
- 029500 03 NE-P PIC X.
- 029600 03 FILLER PIC X VALUE ".".
- 029700 03 NE-P1 PIC X.
- 029800 03 FILLER PIC X VALUE ".".
- 029900 03 NE-P2 PIC X.
- 030000 03 FILLER PIC X VALUE ".".
- 030100 03 NE-P3 PIC X.
- 030200 03 FILLER PIC X(04) VALUE ". .".
- 030300 03 NW-P PIC X.
- 030400 03 FILLER PIC X VALUE ".".
- 030500 03 NW-P1 PIC X.
- 030600 03 FILLER PIC X VALUE ".".
- 030700 03 NW-P2 PIC X.
- 030800 03 FILLER PIC X VALUE ".".
- 030900 03 NW-P3 PIC X.
- 031000 03 FILLER PIC X(04) VALUE ". .".
- 031100 03 SW-P PIC X.
- 031200 03 FILLER PIC X VALUE ".".
- 031300 03 SW-P1 PIC X.
- 031400 03 FILLER PIC X VALUE ".".
- 031500 03 SW-P2 PIC X.
- 031600 03 FILLER PIC X VALUE ".".
- 031700 03 SW-P3 PIC X.
- 031800 03 FILLER PIC X(04) VALUE ". .".
- 031900 03 SE-P PIC X.
- 032000 03 FILLER PIC X VALUE ".".
- 032100 03 SE-P1 PIC X.
- 032200 03 FILLER PIC X VALUE ".".
- 032300 03 SE-P2 PIC X.
- 032400 03 FILLER PIC X VALUE ".".
- 032500 03 SE-P3 PIC X.
- 032600 03 FILLER PIC XXX VALUE ". ".
- 032700 03 ACRES-P PIC X(5).
- 032800 03 FILLER PIC X(5) VALUE SPACES.
- 032900 03 SURF-OWN-P PIC X(4).
- 033000 03 FILLER PIC X(4) VALUE SPACES.
- 033100 03 JURIS-P PIC X(4).
- 033200 03 FILLER PIC X(3) VALUE SPACES.
- 033300 03 ADMIN-P PIC X(4).
- 033400 03 FILLER PIC X(5) VALUE SPACES.
- 033500 03 LAND-TYP-P PIC X(4).
- 033600 03 FILLER PIC X(4) VALUE SPACES.
- 033700 01 PRINT-4 VALUE SPACES.
- 033800 03 FILLER PIC X(15).
- 033900 03 TWNSHIP-ERR PIC X(6).
- 034000 03 FILLER PIC X(2).
- 034100 03 RNGE-ERR PIC X(6).
- 034200 03 FILLER PIC X(3).
- 034300 03 SECT-ERR PIC X(3).
- 034400 03 FILLER PIC X(5).
- 034500 03 SWA-ERR PIC X(4).
- 034600 03 FILLER PIC XX.
- 034700 03 NE-ERR PIC X(9).
- 034800 03 FILLER PIC X(2).
- 034900 03 NW-ERR PIC X(9).
- 035000 03 FILLER PIC X(2).
- 035100 03 SW-ERR PIC X(9).
- 035200 03 FILLER PIC X(2).
- 035300 03 SE-ERR PIC X(9).
- 035400 03 FILLER PIC X(2).
- 035500 03 ACRES-ERR PIC X(5).
- 035600 03 FILLER PIC X(5).
- 035700 03 SURF-ERR PIC X(4).
- 035800 03 FILLER PIC X(4).
- 035900 03 JURIS-ERR PIC X(4).
- 036000 03 FILLER PIC X(3).
- 036100 03 ADMIN-ERR PIC X(4).
- 036200 03 FILLER PIC X(5).
- 036300 03 LND-TYP-ERR PIC X(4).
- 036400 03 FILLER PIC X(4).
- 036500 01 INFO-LIN-1.
- 036600 03 FILLER PIC X(24) VALUE SPACES.
- 036700 03 FILLER PIC X(38) VALUE
- 036800 "IF ERROR CORRECTION IS IN COMMON DATA ".
- 036900 03 FILLER PIC X(46) VALUE
- 037000 "(1-29), KEY ALL RECORDS WITH SAME COMMON DATA.".
- 037100 03 FILLER PIC X(24) VALUE SPACES.
- 037200 01 INFO-LIN-2.
- 037300 03 FILLER PIC X(24) VALUE SPACES.
- 037400 03 FILLER PIC X(42) VALUE
- 037500 "IF ERROR CORRECTION IS IN FIELD POSITIONS ".
- 037600 03 FILLER PIC X(45) VALUE
- 037700 "(30-89), KEY (1-35) AND RED CORRECTED FIELDS.".
- 037800 03 FILLER PIC X(21) VALUE SPACES.
- 037900 PROCEDURE DIVISION.
- 038000 START-SECTION.
- 038100 OPEN INPUT VA1K-IN,
- 038200 OUTPUT PRINT-FILE, VA1Z-OUT. READY DIC-DE.
- 038300 ACCEPT DATE-H FROM DATE. MOVE DAY-H TO DD.
- 038400 MOVE MO-T (MON-H) TO MMM. MOVE YEAR-H TO YY.
- 038500 010-READ.
- 038600 READ VA1K-IN AT END GO TO 260-END.
- 038700 IF SDRP-I1 = "WY047825"
- 038800 MOVE "WY048835" TO SDRP-I1.
- 038900 MOVE VA1K-RCD TO RECORD-VA1D.
- 039000 020-HOLD.
- 039100 MOVE BLM-ADM-4 TO BLM-ADM-HOLD.
- 039200 MOVE ALLOT-NUM TO ALLOT-NUM-HOLD.
- 039300 MOVE PASTURE-NUM TO PASTURE-NUM-HOLD.
- 039400 MOVE MAP-SRC-IN TO MAP-SRC-HOLD.
- 039500 MOVE MTR-MER-CD-IN TO MTR-MER-CD-HOLD.
- 039600 025-EDIT-RCD-TYP.
- 039700 IF DIC-VA1D = "VA1D"
- 039800 GO TO 035-BLM-ST.
- 039900 IF REC-TYP = "VA"
- 040000 GO TO 030-ERROR-VA.
- 040100 DISPLAY "RECORD NOT PROCESSED" VA1K-RCD.
- 040200 GO TO 010-READ.
- 040300 030-ERROR-VA.
- 040400 MOVE 1 TO HDR-SW1.
- 040500 MOVE ALL "*" TO RCD-ERR.
- 040600 035-BLM-ST.
- 040700 MOVE AD-ST-IN TO DE-CD-8822-DEC.
- 040800 MOVE 0003 TO DE-NO-8801-DEC.
- 040900 FIND ANY CODE-DEC.
- 041000 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 041100 IF OK
- 041200 GET CODE-DEC
- 041300 MOVE DE-CD-NAM-8823-DEC TO FUNC-HOLD
- 041400 MOVE STATE-NAME TO ST-HDR
- 041500 GO TO 040-BLM-DIST.
- 041600 MOVE 1 TO HDR-SW1.
- 041700 MOVE "UNKNOWN" TO ST-HDR, DIST-HDR.
- 041800 MOVE ALL "*" TO ST-ERR, DT-ERR, RA-ERR, PLU-ERR.
- 041900 GO TO 060-EXIT-BLM.
- 042000 040-BLM-DIST.
- 042100 MOVE BLM-ADM-2 TO DE-CD-8822-DEC.
- 042200 MOVE 0003 TO DE-NO-8801-DEC.
- 042300 FIND ANY CODE-DEC.
- 042400 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 042500 IF OK
- 042600 GET CODE-DEC
- 042700 GO TO 045-FIND-DT.
- 042800 MOVE "UNKNOWN" TO DIST-HDR.
- 042900 MOVE 1 TO HDR-SW1.
- 043000 MOVE ALL "*" TO DT-ERR, RA-ERR, PLU-ERR.
- 043100 GO TO 060-EXIT-BLM.
- 043200 045-FIND-DT.
- 043300 FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
- 043400 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 043500 IF OK
- 043600 GET CODE-EXPL-DECE
- 043700 MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HOLD
- 043800 MOVE DIST-NAME TO DIST-HDR
- 043900 GO TO 050-BLM-RA.
- 044000 MOVE "UNKNOWN" TO DIST-HDR.
- 044100 050-BLM-RA.
- 044200 MOVE BLM-ADM-3 TO DE-CD-8822-DEC.
- 044300 MOVE 0003 TO DE-NO-8801-DEC.
- 044400 FIND ANY CODE-DEC.
- 044500 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 044600 IF OK
- 044700 GO TO 055-BLM-PLU.
- 044800 MOVE 1 TO HDR-SW1.
- 044900 MOVE ALL "*" TO RA-ERR, PLU-ERR.
- 045000 GO TO 060-EXIT-BLM.
- 045100 055-BLM-PLU.
- 045200 MOVE BLM-ADM-4 TO DE-CD-8822-DEC.
- 045300 MOVE 0003 TO DE-NO-8801-DEC.
- 045400 FIND ANY CODE-DEC.
- 045500 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 045600 IF OK
- 045700 GO TO 060-EXIT-BLM.
- 045800 MOVE ALL "*" TO PLU-ERR.
- 045900 MOVE 1 TO HDR-SW1.
- 046000 060-EXIT-BLM.
- 046100 EXIT.
- 046200 065-EDIT-ALLOT.
- 046300 IF ALLOT-NUM NUMERIC
- 046400 GO TO 070-EDIT-PASTURE.
- 046500 MOVE 1 TO HDR-SW1.
- 046600 MOVE ALL "*" TO ALLOT-ERR.
- 046700 070-EDIT-PASTURE.
- 046800 IF PASTURE-NUM = SPACES
- 046900 GO TO 075-MAP-SRC.
- 047000 IF PASTURE-NUM = ZERO
- 047100 GO TO 075-MAP-SRC.
- 047200 IF PASTURE-NUM NUMERIC AND PASTURE-NUM > ZERO
- 047300 GO TO 075-MAP-SRC.
- 047400 MOVE 1 TO HDR-SW1.
- 047500 MOVE ALL "*" TO PASTURE-ERR.
- 047600 075-MAP-SRC.
- 047700 MOVE 3540 TO DE-NO-8801-DEC.
- 047800 MOVE MAP-SRC-IN TO DE-CD-8822-DEC.
- 047900 FIND ANY CODE-DEC. MOVE DB-STATUS TO DATA-BASE-STATUS.
- 048000 IF NOT OK MOVE 1 TO HDR-SW1, MOVE ALL "*" TO MAP-ERR.
- 048100 IF 1ST-TIME-FLG NOT ZERO GO TO 082-CHK-AD-ST-IN.
- 048200 MOVE 1 TO 1ST-TIME-FLG. MOVE 0100 TO DE-NO-8801-DEC.
- 048300 MOVE AD-ST-IN TO AD-ST-H, DE-CD-8822-DEC.
- 048400 FIND ANY CODE-DEC. MOVE DB-STATUS TO DATA-BASE-STATUS.
- 048500 IF NOT OK DISPLAY "STATE ", AD-ST-IN,
- 048600 " NOT IN DE DIC - RUN ABORTED" CALL "ABOR".
- 048700 FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
- 048800 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 048900 IF NOT OK DISPLAY "NO DE FOR STATE ",
- 049000 AD-ST-IN, " - RUN ABORTED" CALL "ABOR".
- 049100 080-GET-LOOP.
- 049200 GET. MOVE DE-CD-EXPLN-8827-DECE TO DE-CD-EXPLN-8827-DECE-H.
- 049300 MOVE DE-H TO DE-T (SS1A).
- 049400 FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
- 049500 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 049600 IF NOT OK GO TO 082-CHK-AD-ST-IN.
- 049700 ADD 1 TO SS1A. IF SS1A > 5 DISPLAY
- 049800 "MORE THAN 5 DE'S FOR STATE ", AD-ST-IN,
- 049900 " - RUN ABORTED" CALL "ABOR". GO TO 080-GET-LOOP.
- 050000 082-CHK-AD-ST-IN.
- 050100 IF AD-ST-IN NOT = AD-ST-H DISPLAY "STATE IN ", AD-ST-IN,
- 050200 " NOT EQUAL TO STATE HOLD ", AD-ST-H,
- 050300 " - RUN ABORTED" CALL "ABOR".
- 050400 MOVE MTR-MER-CD-IN TO MER-H. MOVE TWP-RNG-IN TO TWP-RNG-H.
- 050500 MOVE MER-TWP-RNG-H TO DE-EXT-CD-8824-DEE. MOVE 1 TO SS1A.
- 050600 084-DE-LOOP.
- 050700 MOVE DE-T (SS1A) TO DE-NO-8801-DEE.
- 050800 IF DE-NO-8801-DEE = 9999 GO TO 090-MER-TWP-RNG-ERR.
- 050900 FIND ANY EXT-CODE-DEE. MOVE DB-STATUS TO DATA-BASE-STATUS.
- 051000 IF NOT OK GO TO 088-CHK-SS1A.
- 051100 IF SEC-SECT-IN NOT NUMERIC
- 051200 OR SEC-SECT-IN < "001" OR > "036" GO TO 092-SEC-ERR.
- 051300 FIND NEXT EXT-CODE-EXPL-DEEE WITHIN DEE-DEEE.
- 051400 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 051500 IF NOT OK DISPLAY "NO SECTIONS FOR MER, TWP, RNG ",
- 051600 MER-TWP-RNG-H, " - RUN ABORTED" CALL "ABOR".
- 051700 086-GET-LOOP.
- 051800 GET.
- 051900 MOVE DE-EXT-CD-NAM-8825-DEEE TO DE-EXT-CD-NAM-8825-DEEE-H.
- 052000 IF ALL-SEC = "X" OR 1-SEC (SEC-C2-3-IN) = "X"
- 052100 GO TO 100-SWA.
- 052200 FIND NEXT EXT-CODE-EXPL-DEEE WITHIN DEE-DEEE.
- 052300 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 052400 IF NOT OK GO TO 092-SEC-ERR. GO TO 086-GET-LOOP.
- 052500 088-CHK-SS1A.
- 052600 IF SS1A < 6 ADD 1 TO SS1A GO TO 084-DE-LOOP.
- 052700 090-MER-TWP-RNG-ERR.
- 052800 MOVE ALL "*" TO MERID-ERR, TWNSHIP-ERR, RNGE-ERR.
- 052900 MOVE 1 TO HDR-SW2.
- 053000 092-SEC-ERR.
- 053100 MOVE ALL "*" TO SECT-ERR.
- 053200 MOVE 1 TO HDR-SW2.
- 053300 100-SWA.
- 053400 IF SWA-CD NOT ALPHABETIC OR SWA-CD = SPACE
- 053500 OR SWA-NUM NOT NUMERIC
- 053600 MOVE 1 TO HDR-SW2 MOVE ALL "*" TO SWA-ERR.
- 053700 105-ALIQ-1.
- 053800 IF ALIQ-1 (SUB) NOT = SPACES AND "X"
- 053900 PERFORM 125-ALIQ-ERR.
- 054000 ADD 1 TO SUB.
- 054100 IF SUB = 5
- 054200 MOVE 1 TO SUB
- 054300 GO TO 110-ALIQ-2.
- 054400 GO TO 105-ALIQ-1.
- 054500 110-ALIQ-2.
- 054600 IF ALIQ-2 (SUB) NOT = SPACES AND "X"
- 054700 PERFORM 125-ALIQ-ERR.
- 054800 ADD 1 TO SUB.
- 054900 IF SUB = 5
- 055000 MOVE 1 TO SUB
- 055100 GO TO 115-ALIQ-3.
- 055200 GO TO 110-ALIQ-2.
- 055300 115-ALIQ-3.
- 055400 IF ALIQ-3 (SUB) NOT = SPACES AND "X"
- 055500 PERFORM 125-ALIQ-ERR.
- 055600 ADD 1 TO SUB.
- 055700 IF SUB = 5
- 055800 MOVE 1 TO SUB
- 055900 GO TO 120-ALIQ-4.
- 056000 GO TO 115-ALIQ-3.
- 056100 120-ALIQ-4.
- 056200 IF ALIQ-4 (SUB) NOT = SPACES AND "X"
- 056300 PERFORM 125-ALIQ-ERR.
- 056400 ADD 1 TO SUB.
- 056500 IF SUB = 5
- 056600 MOVE 1 TO SUB
- 056700 GO TO 130-EXIT-ALIQ.
- 056800 GO TO 120-ALIQ-4.
- 056900 125-ALIQ-ERR.
- 057000 IF SUB = 1
- 057100 MOVE ALL "*" TO NE-ERR.
- 057200 IF SUB = 2
- 057300 MOVE ALL "*" TO NW-ERR.
- 057400 IF SUB = 3
- 057500 MOVE ALL "*" TO SW-ERR.
- 057600 IF SUB = 4
- 057700 MOVE ALL "*" TO SE-ERR.
- 057800 MOVE 1 TO HDR-SW2.
- 057900 130-EXIT-ALIQ.
- 058000 EXIT.
- 058100 140-ACRES.
- 058200 IF ACR-DU-OWNR NUMERIC AND ACR-DU-OWNR > ZERO
- 058300 GO TO 145-OWNERSHIP.
- 058400 MOVE 1 TO HDR-SW2.
- 058500 MOVE ALL "*" TO ACRES-ERR.
- 058600 145-OWNERSHIP.
- 058700 IF OWN-TYP = "TOTL"
- 058800 PERFORM 400-ZERO-OUT
- 058900 MOVE 1 TO TOTL-SW
- 059000 GO TO 164-TOTL-SW.
- 059100 IF OWN-TYP-2 = "NC" OR "NP" OR
- 059200 "NQ" OR "NS" OR "NT"
- 059300 GO TO 146-BLANK.
- 059400 IF OWN-TYP-2 = "FA" OR "FP"
- 059500 GO TO 150-JURIS.
- 059600 IF OWN-TYP-1 = "P" OR "S"
- 059700 GO TO 146-BLANK.
- 059800 MOVE 1 TO HDR-SW2.
- 059900 MOVE ALL "*" TO SURF-ERR.
- 060000 GO TO 150-JURIS.
- 060100 146-BLANK.
- 060200 IF JURIS NOT = TO SPACES
- 060300 MOVE 1 TO HDR-SW2
- 060400 MOVE ALL "*" TO JURIS-ERR SURF-ERR.
- 060500 IF MGT-ADM NOT = TO SPACES
- 060600 MOVE 1 TO HDR-SW2
- 060700 MOVE ALL "*" TO ADMIN-ERR SURF-ERR.
- 060800 IF LAND-TYP NOT = TO SPACES
- 060900 MOVE 1 TO HDR-SW2
- 061000 MOVE ALL "*" TO LND-TYP-ERR SURF-ERR.
- 061100 GO TO 165-EXIT-EDIT.
- 061200 150-JURIS.
- 061300 MOVE JURIS TO DE-CD-8822-DEC.
- 061400 MOVE 2576 TO DE-NO-8801-DEC.
- 061500 FIND ANY CODE-DEC.
- 061600 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 061700 IF OK
- 061800 GO TO 155-ADMIN.
- 061900 MOVE 1 TO HDR-SW2.
- 062000 MOVE ALL "*" TO JURIS-ERR.
- 062100 155-ADMIN.
- 062200 MOVE MGT-ADM TO DE-CD-8822-DEC.
- 062300 MOVE 2576 TO DE-NO-8801-DEC.
- 062400 FIND ANY CODE-DEC.
- 062500 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 062600 IF OK
- 062700 GO TO 160-TYP-LAND.
- 062800 MOVE 1 TO HDR-SW2.
- 062900 MOVE ALL "*" TO ADMIN-ERR.
- 063000 160-TYP-LAND.
- 063100 MOVE LAND-TYP TO DE-CD-8822-DEC.
- 063200 MOVE 3801 TO DE-NO-8801-DEC.
- 063300 FIND ANY CODE-DEC.
- 063400 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 063500 IF OK
- 063600 GO TO 165-EXIT-EDIT.
- 063700 MOVE 1 TO HDR-SW2.
- 063800 MOVE ALL "*" TO LND-TYP-ERR.
- 063900 164-TOTL-SW.
- 064000 IF TOTL-SW = 1
- 064100 MOVE ZERO TO TOTL-SW
- 064200 GO TO 010-READ.
- 064300 165-EXIT-EDIT.
- 064400 EXIT.
- 064500 168-SWITCH-CHECK.
- 064600 IF HDR-SW1 = ZERO
- 064700 GO TO 180-HDR-SW2.
- 064800 IF PAGE-SW = 1
- 064900 PERFORM 410-HDR-ST-DIST
- 065000 MOVE ZERO TO PAGE-SW.
- 065100 PERFORM 420-HDRS-CNTL.
- 065200 170-WRITE-CONTROL.
- 065300 PERFORM 430-MOVE-CTL-DATA.
- 065400 MOVE PRINT-2 TO PRINT-RCD.
- 065500 WRITE PRINT-RCD BEFORE 2.
- 065600 ADD 2 TO LINE-CNT.
- 065700 MOVE 1 TO ERROR-SW.
- 065800 175-WRITE-LIN-DATA.
- 065900 PERFORM 440-HDRS-LIN-DATA.
- 066000 PERFORM 450-LIN-DATA.
- 066100 IF HDR-SW2 = ZERO
- 066200 MOVE SPACES TO PRINT-RCD
- 066300 ELSE
- 066400 MOVE PRINT-4 TO PRINT-RCD
- 066500 MOVE 1 TO ERROR-SW.
- 066600 WRITE PRINT-RCD BEFORE 2.
- 066700 ADD 2 TO LINE-CNT.
- 066800 176-DUMMY.
- 066900 GO TO 185-NEW-RCD.
- 067000 180-HDR-SW2.
- 067100 IF HDR-SW2 = ZERO
- 067200 GO TO 185-NEW-RCD.
- 067300 IF PAGE-SW = ZERO
- 067400 PERFORM 175-WRITE-LIN-DATA
- 067500 GO TO 185-NEW-RCD.
- 067600 PERFORM 410-HDR-ST-DIST THRU 430-MOVE-CTL-DATA.
- 067700 MOVE SPACES TO PRINT-RCD.
- 067800 WRITE PRINT-RCD BEFORE 2.
- 067900 ADD 2 TO LINE-CNT.
- 068000 PERFORM 440-HDRS-LIN-DATA THRU 450-LIN-DATA.
- 068100 MOVE PRINT-4 TO PRINT-RCD.
- 068200 WRITE PRINT-RCD BEFORE 2.
- 068300 ADD 2 TO LINE-CNT.
- 068400 MOVE ZERO TO PAGE-SW.
- 068500 185-NEW-RCD.
- 068600 IF PASTURE-NUM = SPACES
- 068700 MOVE ZERO TO PASTURE-NUM.
- 068800 MOVE RECORD-VA1D TO VA1Z-RCD.
- 068900 WRITE VA1Z-RCD.
- 069000 195-READ-VA1K.
- 069100 READ VA1K-IN AT END GO TO 260-END.
- 069200 IF SDRP-I1 = "WY047825"
- 069300 MOVE "WY048835" TO SDRP-I1.
- 069400 MOVE VA1K-RCD TO RECORD-VA1D.
- 069500 IF DIC-VA1D = "VA1D"
- 069600 GO TO 200-BLM-ST.
- 069700 IF REC-TYP = "VA"
- 069800 PERFORM 030-ERROR-VA
- 069900 GO TO 200-BLM-ST.
- 070000 DISPLAY "RECORD NOT PROCESSED".
- 070100 DISPLAY VA1K-RCD.
- 070200 GO TO 195-READ-VA1K.
- 070300 200-BLM-ST.
- 070400 IF AD-ST-IN = ST-HOLD
- 070500 GO TO 210-BLM-DIST.
- 070600 PERFORM 205-NEW-PAGE.
- 070700 GO TO 035-BLM-ST.
- 070800 205-NEW-PAGE.
- 070900 MOVE ZERO TO PAGE-NO.
- 071000 PERFORM 400-ZERO-OUT.
- 071100 PERFORM 020-HOLD.
- 071200 210-BLM-DIST.
- 071300 IF BLM-ADM-DIST = DT-HOLD
- 071400 GO TO 215-BLM-RA.
- 071500 PERFORM 205-NEW-PAGE.
- 071600 MOVE SPACES TO PRINT-2, PRINT-4.
- 071700 GO TO 035-BLM-ST.
- 071800 215-BLM-RA.
- 071900 IF BLM-ADM-RA = RA-HOLD
- 072000 GO TO 220-BLM-PLU.
- 072100 MOVE 1 TO PAGE-SW.
- 072200 PERFORM 400-ZERO-OUT.
- 072300 PERFORM 020-HOLD.
- 072400 GO TO 035-BLM-ST.
- 072500 220-BLM-PLU.
- 072600 IF BLM-ADM-PLU = PLU-HOLD
- 072700 GO TO 225-EDIT-ALLOT.
- 072800 MOVE 1 TO PAGE-SW.
- 072900 PERFORM 400-ZERO-OUT.
- 073000 PERFORM 020-HOLD.
- 073100 GO TO 035-BLM-ST.
- 073200 225-EDIT-ALLOT.
- 073300 IF ALLOT-NUM = ALLOT-NUM-HOLD
- 073400 GO TO 230-PASTURE.
- 073500 MOVE 1 TO PAGE-SW.
- 073600 PERFORM 400-ZERO-OUT.
- 073700 PERFORM 020-HOLD.
- 073800 GO TO 065-EDIT-ALLOT.
- 073900 230-PASTURE.
- 074000 IF PASTURE-NUM = PASTURE-NUM-HOLD
- 074100 GO TO 235-MAP.
- 074200 MOVE 1 TO PAGE-SW.
- 074300 PERFORM 400-ZERO-OUT.
- 074400 PERFORM 020-HOLD.
- 074500 GO TO 070-EDIT-PASTURE.
- 074600 235-MAP.
- 074700 IF MAP-SRC-IN = MAP-SRC-HOLD
- 074800 GO TO 240-MERIDIAN.
- 074900 MOVE 1 TO PAGE-SW.
- 075000 PERFORM 400-ZERO-OUT.
- 075100 PERFORM 020-HOLD.
- 075200 GO TO 075-MAP-SRC.
- 075300 240-MERIDIAN.
- 075400 IF MTR-MER-CD-IN = MTR-MER-CD-HOLD
- 075500 GO TO 245-CONTROL-EQUAL.
- 075600 MOVE 1 TO PAGE-SW.
- 075700 PERFORM 400-ZERO-OUT.
- 075800 PERFORM 020-HOLD.
- 075900 GO TO 082-CHK-AD-ST-IN.
- 076000 245-CONTROL-EQUAL.
- 076100 MOVE SPACES TO PRINT-4.
- 076200 MOVE ZERO TO HDR-SW2.
- 076300 PERFORM 082-CHK-AD-ST-IN THRU 165-EXIT-EDIT.
- 076400 IF OWN-TYP = "TOTL"
- 076500 PERFORM 400-ZERO-OUT
- 076600 GO TO 195-READ-VA1K.
- 076700 IF HDR-SW1 NOT = TO ZERO
- 076800 GO TO 246-PAGE.
- 076900 IF HDR-SW2 = ZERO
- 077000 GO TO 185-NEW-RCD.
- 077100 246-PAGE.
- 077200 IF PAGE-SW = ZERO
- 077300 GO TO 250-CONTINUE.
- 077400 MOVE ZERO TO PAGE-SW.
- 077500 PERFORM 410-HDR-ST-DIST THRU 430-MOVE-CTL-DATA.
- 077600 IF HDR-SW1 = ZERO
- 077700 MOVE SPACES TO PRINT-RCD
- 077800 ELSE
- 077900 MOVE PRINT-2 TO PRINT-RCD
- 078000 MOVE 1 TO ERROR-SW.
- 078100 WRITE PRINT-RCD BEFORE 2.
- 078200 ADD 2 TO LINE-CNT.
- 078300 PERFORM 440-HDRS-LIN-DATA.
- 078400 250-CONTINUE.
- 078500 PERFORM 450-LIN-DATA.
- 078600 IF HDR-SW2 = ZERO
- 078700 MOVE SPACES TO PRINT-RCD
- 078800 ELSE
- 078900 MOVE PRINT-4 TO PRINT-RCD
- 079000 MOVE 1 TO ERROR-SW.
- 079100 MOVE 0 TO HDR-SW2.
- 079200 WRITE PRINT-RCD BEFORE 2.
- 079300 ADD 2 TO LINE-CNT.
- 079400 IF LINE-CNT > 54
- 079500 MOVE 1 TO PAGE-SW.
- 079600 GO TO 185-NEW-RCD.
- 079700 260-END.
- 079800 IF ERROR-SW = 1
- 079900 MOVE ERR-CNT TO CNT-ERRS, DISPLAY ERR-LINE
- 080000 ELSE DISPLAY " NO ERRORS DETECTED".
- 080100 CLOSE PRINT-FILE, VA1K-IN, VA1Z-OUT.
- 080200 FINISH DIC-DE, STOP RUN.
- 080300 400-ZERO-OUT.
- 080400 MOVE ZERO TO HDR-SW1, HDR-SW2.
- 080500 MOVE SPACES TO PRINT-2, PRINT-4.
- 080600 410-HDR-ST-DIST.
- 080700 PERFORM 460-LINE-CNT.
- 080800 MOVE HDR-1 TO PRINT-RCD.
- 080900 WRITE PRINT-RCD BEFORE 2.
- 081000 MOVE HDR-2 TO PRINT-RCD.
- 081100 WRITE PRINT-RCD BEFORE 2.
- 081200 MOVE INFO-LIN-1 TO PRINT-RCD.
- 081300 WRITE PRINT-RCD BEFORE 1.
- 081400 MOVE INFO-LIN-2 TO PRINT-RCD.
- 081500 WRITE PRINT-RCD BEFORE 2.
- 081600 ADD 7 TO LINE-CNT.
- 081700 420-HDRS-CNTL.
- 081800 MOVE HDR-3 TO PRINT-RCD.
- 081900 WRITE PRINT-RCD BEFORE 1.
- 082000 MOVE HDR-4 TO PRINT-RCD.
- 082100 WRITE PRINT-RCD BEFORE 1.
- 082200 MOVE HDR-5 TO PRINT-RCD.
- 082300 WRITE PRINT-RCD BEFORE 2.
- 082400 ADD 4 TO LINE-CNT.
- 082500 430-MOVE-CTL-DATA.
- 082600 MOVE DIC-VA1D TO REC-TYP-P.
- 082700 MOVE AD-ST-IN TO AD-ST-P.
- 082800 MOVE BLM-ADM-DIST TO BLM-ADM-DIST-P.
- 082900 MOVE BLM-ADM-RA TO BLM-ADM-RA-P.
- 083000 MOVE BLM-ADM-PLU TO BLM-ADM-PLU-P.
- 083100 MOVE DATA-DATE TO DATA-DATE-P.
- 083200 MOVE ALLOT-NUM TO ALLOT-NUM-P.
- 083300 MOVE PASTURE-NUM TO PASTURE-NUM-P.
- 083400 MOVE ACTN-CD TO ACTN-CD-P.
- 083500 MOVE MAP-SRC-IN TO MAP-SOURCE-P.
- 083600 MOVE MTR-MER-CD-IN TO MERIDIAN-P.
- 083700 MOVE PRINT-1 TO PRINT-RCD.
- 083800 WRITE PRINT-RCD BEFORE 1.
- 083900 ADD 1 TO LINE-CNT.
- 084000 440-HDRS-LIN-DATA.
- 084100 MOVE HDR-6 TO PRINT-RCD.
- 084200 WRITE PRINT-RCD BEFORE 1.
- 084300 MOVE HDR-7 TO PRINT-RCD.
- 084400 WRITE PRINT-RCD BEFORE 1.
- 084500 MOVE HDR-8 TO PRINT-RCD.
- 084600 WRITE PRINT-RCD BEFORE 2.
- 084700 ADD 4 TO LINE-CNT.
- 084800 450-LIN-DATA.
- 084900 MOVE LIN-NUM TO LIN-NUM-P.
- 085000 MOVE TWNSHIP-3 TO TWNSHIP-P.
- 085100 MOVE TWNSHIP-2 TO TWNSHIP-P1.
- 085200 MOVE RNGE-3 TO RNGE-P.
- 085300 MOVE RNGE-2 TO RNGE-P1.
- 085400 MOVE SEC-SECT-IN TO SECT-P.
- 085500 MOVE SWA TO SWA-P.
- 085600 MOVE ALIQ-1 (1) TO NE-P.
- 085700 MOVE ALIQ-2 (1) TO NE-P1.
- 085800 MOVE ALIQ-3 (1) TO NE-P2.
- 085900 MOVE ALIQ-4 (1) TO NE-P3.
- 086000 MOVE ALIQ-1 (2) TO NW-P.
- 086100 MOVE ALIQ-2 (2) TO NW-P1.
- 086200 MOVE ALIQ-3 (2) TO NW-P2.
- 086300 MOVE ALIQ-4 (2) TO NW-P3.
- 086400 MOVE ALIQ-1 (3) TO SW-P.
- 086500 MOVE ALIQ-2 (3) TO SW-P1.
- 086600 MOVE ALIQ-3 (3) TO SW-P2.
- 086700 MOVE ALIQ-4 (3) TO SW-P3.
- 086800 MOVE ALIQ-1 (4) TO SE-P.
- 086900 MOVE ALIQ-2 (4) TO SE-P1.
- 087000 MOVE ALIQ-3 (4) TO SE-P2.
- 087100 MOVE ALIQ-4 (4) TO SE-P3.
- 087200 MOVE ACR-DU-OWNR TO ACRES-P.
- 087300 MOVE OWN-TYP TO SURF-OWN-P.
- 087400 MOVE JURIS TO JURIS-P.
- 087500 MOVE MGT-ADM TO ADMIN-P.
- 087600 MOVE LAND-TYP TO LAND-TYP-P.
- 087700 MOVE PRINT-3 TO PRINT-RCD.
- 087800 ADD 1 TO ERR-CNT.
- 087900 WRITE PRINT-RCD BEFORE 1.
- 088000 ADD 1 TO LINE-CNT.
- 088100 460-LINE-CNT.
- 088200 MOVE SPACES TO PRINT-RCD.
- 088300 WRITE PRINT-RCD BEFORE PAGE.
- 088400 MOVE ZERO TO LINE-CNT.
- 088500 MOVE 0 TO PAGE-SW.
- 088600 ADD 1 TO PAGE-NO.
- 088700 MOVE PAGE-NO TO PAGE-CNT.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES230M.
- 000300* VA SUMMARY
- 000400*
- 000500 AUTHOR. CHUCK SLIZEWSKI.
- 000600 DATE-WRITTEN. 01/10/79.
- 000700 DATE-COMPILED.
- 000800 ENVIRONMENT DIVISION.
- 000900 CONFIGURATION SECTION.
- 001000 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001100 OBJECT-COMPUTER. LEVEL-66-ASCII.
- 001200 INPUT-OUTPUT SECTION.
- 001300 FILE-CONTROL.
- 001400 SELECT FIL-D1 ASSIGN TO D1
- 001500 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001600 SELECT FIL-I1 ASSIGN TO I1
- 001700 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001800 SELECT FIL-W1 ASSIGN TO W1
- 001900 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002000 DATA DIVISION.
- 002100 FILE SECTION.
- 002200 FD FIL-D1
- 002300 LABEL RECORDS ARE STANDARD
- 002400 CODE-SET IS GBCD
- 002500 DATA RECORD IS REC-D1.
- 002600 01 REC-D1.
- 002700 03 FILLER PIC XXXX.
- 002800 03 STATE-THRU-PAST-D1 PIC X(14).
- 002900 03 FILLER PIC X(11).
- 003000 03 MERID-D1 PIC XX.
- 003100 03 FILLER PIC XXXX.
- 003200 03 TN-RG-SEC-D1 PIC X(13).
- 003300 03 SWA-D1 PIC XXXX.
- 003400 03 FILLER PIC X(16).
- 003500 03 ACRES-D1 PIC 9(5).
- 003600 03 OWNER-D1 PIC X(16).
- 003700 03 FILLER PIC X.
- 003800 FD FIL-I1
- 003900 LABEL RECORDS ARE STANDARD
- 004000 CODE-SET IS GBCD
- 004100 DATA RECORD IS REC-I1.
- 004200 01 REC-I1 PIC X(90).
- 004300 SD FIL-W1
- 004400 DATA RECORD IS REC-W1.
- 004500 01 REC-W1.
- 004600 03 FILLER PIC XXXX.
- 004700 03 STATE-THRU-PAST-W1 PIC X(14).
- 004800 03 FILLER PIC X(11).
- 004900 03 MERID-W1 PIC XX.
- 005000 03 FILLER PIC XXXX.
- 005100 03 TN-RG-SEC-W1 PIC X(13).
- 005200 03 SWA-W1 PIC XXXX.
- 005300 03 FILLER PIC X(16).
- 005400 03 ACRES-W1 PIC 9(5).
- 005500 03 OWNER-W1 PIC X(16).
- 005600 03 FILLER PIC X.
- 005700 WORKING-STORAGE SECTION.
- 005800 77 AD-CNTR PIC 9(5) COMP-4 VALUE ZERO.
- 005900 77 IN-CNTR PIC 9(5) COMP-4 VALUE ZERO.
- 006000 77 OT-CNTR PIC 9(5) COMP-4 VALUE 1.
- 006100 PROCEDURE DIVISION.
- 006200 SS SECTION.
- 006300 SSP.
- 006400 SORT FIL-W1 ON ASCENDING KEY STATE-THRU-PAST-W1,
- 006500 SWA-W1,
- 006600 MERID-W1,
- 006700 TN-RG-SEC-W1,
- 006800 OWNER-W1,
- 006900 INPUT PROCEDURE IS IN-PROC,
- 007000 OUTPUT PROCEDURE IS OT-PROC.
- 007100 IN-PROC SECTION.
- 007200 IPP.
- 007300 OPEN INPUT FIL-I1.
- 007400 0100-READ.
- 007500 READ FIL-I1 AT END GO TO 0200-CLOS.
- 007600 MOVE REC-I1 TO REC-W1. RELEASE REC-W1.
- 007700 ADD 1 TO IN-CNTR. GO TO 0100-READ.
- 007800 0200-CLOS.
- 007900 CLOSE FIL-I1.
- 008000 OT-PROC SECTION.
- 008100 OPP.
- 008200 OPEN OUTPUT FIL-D1.
- 008300 RETURN FIL-W1 AT END
- 008400 DISPLAY "NO RECORDS ON SORT FILE" CALL "ABOR".
- 008500 MOVE REC-W1 TO REC-D1.
- 008600 0300-READ.
- 008700 RETURN FIL-W1 AT END WRITE REC-D1
- 008800 DISPLAY "RECORDS IN = " IN-CNTR
- 008900 DISPLAY "RECORDS ADDED = " AD-CNTR
- 009000 DISPLAY "RECORDS OUT = " OT-CNTR
- 009100 CLOSE FIL-D1 STOP RUN.
- 009200 IF STATE-THRU-PAST-D1 = STATE-THRU-PAST-W1
- 009300 AND MERID-D1 = MERID-W1
- 009400 AND TN-RG-SEC-D1 = TN-RG-SEC-W1
- 009500 AND SWA-D1 = SWA-W1
- 009600 AND OWNER-D1 = OWNER-W1
- 009700 ADD ACRES-W1 TO ACRES-D1
- 009800 ADD 1 TO AD-CNTR GO TO 0300-READ.
- 009900 WRITE REC-D1. ADD 1 TO OT-CNTR.
- 010000 MOVE REC-W1 TO REC-D1. GO TO 0300-READ.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES305M.
- 000300* CONVERTS NEW FORMAT VB RECORDS TO OLD FORMAT VB (D) RECOR
- 000400*
- 000500 AUTHOR. GEORGIA BOSSE.
- 000600 INSTALLATION. BLM.
- 000700 DATE-WRITTEN. DECEMBER 1982.
- 000800*REMARKS. VB CONVERSION-D
- 000900* THE INPUT FILES ARE THE KEY ENTERED VB AND VC RECORDS.
- 001000* VB = BLM FORM 4412-30 (APRIL 1982)
- 001100* VC = BLM FORM 4412-37 (APRIL 1982)
- 001200* THE OUTPUT IS FORMATTED LIKE THE KEY ENTERED VB1D RECORDS
- 001300* VB1D = BLM FORM 4412-30 (JUNE 79)
- 001400* THE PROGRAM SORTS THE VC FILE BY STRATUM INTO A TEMPORARY
- 001500* AND THEN SORTS THE VB FILE BY STRATUM. THE FILES ARE MAT
- 001600* ON STRATUM AND ALL VB RECORDS FOR WHICH THERE IS A MATCHI
- 001700* VC RECORD ARE REFORMATTED INTO THE VB1D FILE. IF NO MATC
- 001800* VC RECORD IS FOUND AN ERROR MESSAGE IS PRINTED AND THE PR
- 001900* READS THE NEXT VB RECORD. IF THE PROGRAM REACHES THE END
- 002000* OF THE VC FILE WITHOUT MATCHING THE VB STRATUM OR FINDING
- 002100* HIGHER STRATUM THE PROGRAM PRINTS A MESSAGE AND TERMINATE
- 002200 ENVIRONMENT DIVISION.
- 002300 CONFIGURATION SECTION.
- 002400 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 002500 OBJECT-COMPUTER. LEVEL-66-ASCII SEQUENCE IS EBCDIC.
- 002600 INPUT-OUTPUT SECTION.
- 002700 FILE-CONTROL.
- 002800 SELECT VB1D-FILE ASSIGN D1
- 002900 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 003000 SELECT VC-FILE ASSIGN I1
- 003100 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 003200 SELECT VB-FILE ASSIGN I2
- 003300 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 003400 SELECT VC-SORT-OUT-FILE ASSIGN DZ.
- 003500 SELECT VC-SORT-FILE ASSIGN ASORT.
- 003600 SELECT VB-SORT-FILE ASSIGN BSORT.
- 003700 DATA DIVISION.
- 003800 FILE SECTION.
- 003900 FD VC-FILE
- 004000 CODE-SET IS GBCD
- 004100 LABEL RECORDS ARE STANDARD
- 004200 DATA RECORD IS VC-REC.
- 004300 01 VC-REC.
- 004400 03 PG-NUM-I1 PIC 9999.
- 004500 03 INV-CD-I1 PIC XXXX.
- 004600 03 REC-TYP-I1 PIC XXX.
- 004700 03 LINE-NUM-I1 PIC XX.
- 004800 03 ACT-I1 PIC X.
- 004900 03 RS-NUM-I1 PIC X(11).
- 005000 03 STRAT-I1 PIC X(4).
- 005100 03 COND-CL-I1 PIC X.
- 005200 03 COND-CL-FIL PIC XXX.
- 005300 03 VEG-SUB-TYP-I1 PIC X(4).
- 005400 03 DOMINANT-PLNT-I1 PIC X(21).
- 005500 03 FILLER PIC X(26).
- 005600 FD VB-FILE
- 005700 CODE-SET IS GBCD
- 005800 LABEL RECORDS ARE STANDARD
- 005900 DATA RECORD IS VB-REC.
- 006000 01 VB-REC.
- 006100 03 PG-I2 PIC X(4).
- 006200 03 INV-CD-I2 PIC X(4).
- 006300 03 REC-TYP-I2 PIC XXX.
- 006400 03 RA-I2 PIC XX.
- 006500 03 PU-I2 PIC XX.
- 006600 03 ALLOT-I2 PIC X(4).
- 006700 03 PASTR-I2 PIC XX.
- 006800 03 LINE-NUM-I2 PIC XX.
- 006900 03 ACT-I2 PIC X.
- 007000 03 SWA-I2 PIC X(4).
- 007100 03 TRN-I2 PIC XX.
- 007200 03 PCT-SWA-I2 PIC XXX.
- 007300 03 STRAT-I2 PIC X(4).
- 007400 03 CLMTC-ADJ-FCTR-I2 PIC X(5).
- 007500 03 ELEV-I2 PIC X(5).
- 007600 03 PCT-SLP-I2 PIC XXX.
- 007700 03 SLP-ASPT-I2 PIC XX.
- 007800 03 LND-FRM-I2 PIC XXX.
- 007900 03 SOIL-PHS-I2 PIC X(6).
- 008000 03 FILLER PIC X(23).
- 008100 FD VB1D-FILE
- 008200 CODE-SET IS GBCD
- 008300 LABEL RECORDS ARE STANDARD
- 008400 DATA RECORD IS VB1D-REC.
- 008500 01 VB1D-REC.
- 008600 03 REC-TYPE-D1 PIC X(4).
- 008700 03 STATE-DIST-D1 PIC X(4).
- 008800 03 RA-D1 PIC XX.
- 008900 03 PU-D1 PIC XX.
- 009000 03 CLMTC-ADJ-FCTR-D1 PIC X(5).
- 009100 03 DATE-D1 PIC X(6).
- 009200 03 ACT-D1 PIC X.
- 009300 03 LINE-NUM-D1 PIC X(4).
- 009400 03 SWA-D1 PIC X(4).
- 009500 03 TRN-D1 PIC XX.
- 009600 03 PCT-SWA-D1 PIC XXX.
- 009700 03 RS-NUM-D1 PIC X(11).
- 009800 03 STRAT-D1 PIC X(4).
- 009900 03 ALLOT-D1 PIC X(4).
- 010000 03 PASTR-D1 PIC XX.
- 010100 03 VEG-SUB-TYP-D1 PIC X(4).
- 010200 03 COND-CL-D1 PIC X.
- 010300 03 PCT-SLP-D1 PIC XXX.
- 010400 03 SLP-ASPT-D1 PIC XX.
- 010500 03 LND-FRM-D1 PIC XXX.
- 010600 03 SOIL-PHS-D1 PIC X(6).
- 010700 03 FILLER PIC X(19).
- 010800 FD VC-SORT-OUT-FILE
- 010900 LABEL RECORDS ARE STANDARD
- 011000 DATA RECORD IS VC-SORT-OUT.
- 011100 01 VC-SORT-OUT.
- 011200 03 PG-NUM-SVC PIC 9999.
- 011300 03 INV-CD-SVC PIC XXXX.
- 011400 03 REC-TYP-SVC PIC XXX.
- 011500 03 LINE-NUM-SVC PIC XX.
- 011600 03 ACT-SVC PIC X.
- 011700 03 RS-NUM-SVC PIC X(11).
- 011800 03 STRAT-SVC PIC X(4).
- 011900 03 COND-CL-SVC PIC X(4).
- 012000 03 VEG-SUB-TYP-SVC PIC X(4).
- 012100 03 DOMINANT-PLNT-SVC PIC X(21).
- 012200 03 FILLER PIC X(26).
- 012300 SD VC-SORT-FILE
- 012400 DATA RECORD IS VC-SORT-REC.
- 012500 01 VC-SORT-REC.
- 012600 03 FILLER PIC X(25).
- 012700 03 STRAT-IS-KEY PIC X(4).
- 012800 03 FILLER PIC X(55).
- 012900 SD VB-SORT-FILE
- 013000 DATA RECORD IS VB-SORT-REC.
- 013100 01 VB-SORT-REC.
- 013200 03 PG-SVB PIC X(4).
- 013300 03 INV-SVB PIC X(4).
- 013400 03 REC-TYP-SVB PIC XXX.
- 013500 03 RA-SVB PIC XX.
- 013600 03 PU-SVB PIC XX.
- 013700 03 ALLOT-SVB PIC X(4).
- 013800 03 PASTR-SVB PIC XX.
- 013900 03 LINE-NUM-SVB PIC XX.
- 014000 03 ACT-SVB PIC X.
- 014100 03 SWA-SVB PIC X(4).
- 014200 03 TRN-SVB PIC XX.
- 014300 03 PCT-SWA-SVB PIC XXX.
- 014400 03 STRAT-SVB PIC X(4).
- 014500 03 CLMTC-ADJ-FCTR-SVB PIC X(5).
- 014600 03 ELEV-SVB PIC X(5).
- 014700 03 PCT-SLP-SVB PIC XXX.
- 014800 03 SLP-ASPT-SVB PIC XX.
- 014900 03 LND-FRM-SVB PIC XXX.
- 015000 03 SOIL-PHS-SVB PIC X(6).
- 015100 03 FILLER PIC X(23).
- 015200 WORKING-STORAGE SECTION.
- 015300 77 ERR-CNT PIC 9 VALUE ZERO.
- 015400 77 VB1D-CNT PIC 99999 VALUE ZERO.
- 015500 77 TODAYS-DATE PIC X(06).
- 015600 01 INV-ST-DIST.
- 015700 03 INVENTORY PIC XXXX.
- 015800 03 STATE-DIST PIC X(4).
- 015900 PROCEDURE DIVISION.
- 016000 A100-HOUSE SECTION.
- 016100 A100-HOUSEKEEPING.
- 016200 ACCEPT TODAYS-DATE FROM DATE.
- 016300 ACCEPT INV-ST-DIST.
- 016400 B200-SORT-VC SECTION.
- 016500 B210-SORT-VC.
- 016600 SORT VC-SORT-FILE ON ASCENDING KEY
- 016700 STRAT-IS-KEY
- 016800 INPUT PROCEDURE IS C300-INPUT-VC
- 016900 GIVING VC-SORT-OUT-FILE.
- 017000 B250-SORT-VB SECTION.
- 017100 B260-SORT-VB.
- 017200 CLOSE VC-FILE.
- 017300 SORT VB-SORT-FILE ON ASCENDING KEY
- 017400 STRAT-SVB
- 017500 INPUT PROCEDURE IS D400-INPUT-VB
- 017600 OUTPUT PROCEDURE IS E600-OUTPUT.
- 017700 B290-STOP.
- 017800 CLOSE VC-SORT-OUT-FILE.
- 017900 DISPLAY " OUTPUT RECORDS=" VB1D-CNT
- 018000 STOP RUN.
- 018100 C300-INPUT-VC SECTION.
- 018200 C310-OPEN.
- 018300 MOVE ZERO TO ERR-CNT.
- 018400 OPEN INPUT VC-FILE.
- 018500 C320-READ-VC-FILE.
- 018600 READ VC-FILE AT END
- 018700 GO TO C300-EXIT.
- 018800 IF REC-TYP-I1 NOT = "VC "
- 018900 ADD 1 TO ERR-CNT
- 019000 DISPLAY " INVALID REC-TYP " VC-REC
- 019100 IF ERR-CNT = 5
- 019200 DISPLAY " CHECK COMPLETE FILE - ABORT - "
- 019300 STOP RUN
- 019400 ELSE
- 019500 GO TO C320-READ-VC-FILE.
- 019600 IF INVENTORY NOT = INV-CD-I1
- 019700 DISPLAY " INVENTORY UNMATCHED WITH VC-REC"
- 019800 DISPLAY " INVENTORY REQUESTED= " INVENTORY
- 019900 DISPLAY "THIS FILE IS " INV-CD-I1
- 020000 STOP RUN.
- 020100 MOVE VC-REC TO VC-SORT-REC.
- 020200 RELEASE VC-SORT-REC.
- 020300 GO TO C320-READ-VC-FILE.
- 020400 C300-EXIT.
- 020500 EXIT.
- 020600 D400-INPUT-VB SECTION.
- 020700 D410-OPEN.
- 020800 MOVE ZERO TO ERR-CNT.
- 020900 OPEN INPUT VB-FILE.
- 021000 D420-READ-VB-FILE.
- 021100 READ VB-FILE AT END
- 021200 GO TO D400-EXIT.
- 021300 IF REC-TYP-I2 NOT = "VB "
- 021400 ADD 1 TO ERR-CNT
- 021500 DISPLAY " INVBLID REC-TYP " VC-REC
- 021600 IF ERR-CNT = 5
- 021700 DISPLAY " CHECK COMPLETE FILE - ABORT - "
- 021800 STOP RUN
- 021900 ELSE
- 022000 GO TO D420-READ-VB-FILE.
- 022100 IF INVENTORY NOT = INV-CD-I2
- 022200 DISPLAY " INVENTORY UNMATCHED WITH VB-REC"
- 022300 DISPLAY " INVENTORY REQUESTED= " INVENTORY
- 022400 DISPLAY "THIS FILE IS " INV-CD-I2
- 022500 STOP RUN.
- 022600 MOVE VB-REC TO VB-SORT-REC.
- 022700 RELEASE VB-SORT-REC.
- 022800 GO TO D420-READ-VB-FILE.
- 022900 D400-EXIT.
- 023000 EXIT.
- 023100 E600-OUTPUT SECTION.
- 023200 E610-OPEN.
- 023300 OPEN INPUT VC-SORT-OUT-FILE.
- 023400 MOVE SPACES TO VB1D-REC.
- 023500 OPEN OUTPUT VB1D-FILE.
- 023600 CLOSE VB-FILE.
- 023700 READ VC-SORT-OUT-FILE AT END
- 023800 DISPLAY "VB SORT FILE ERROR"
- 023900 STOP RUN.
- 024000 E620-RETURN.
- 024100 RETURN VB-SORT-FILE AT END
- 024200 GO TO E600-EXIT.
- 024300 IF STRAT-SVB > STRAT-SVC
- 024400 PERFORM E680-FIND-MATCH.
- 024500 IF STRAT-SVB < STRAT-SVC
- 024600 DISPLAY "STRATUM #" STRAT-SVB
- 024700 " ON THE VB FILE HAS NO MATCHING STRATUM ON THE VC FILE"
- 024800 GO TO E620-RETURN.
- 024900* MOVE STANDARD FILE DATA
- 025000 MOVE STATE-DIST TO STATE-DIST-D1.
- 025100 MOVE "A" TO ACT-D1.
- 025200 MOVE TODAYS-DATE TO DATE-D1.
- 025300 MOVE "VB1D" TO REC-TYPE-D1.
- 025400 MOVE ZEROES TO LINE-NUM-D1.
- 025500* MOVE DATA FROM VB-RECORD
- 025600 MOVE SWA-SVB TO SWA-D1.
- 025700 MOVE RA-SVB TO RA-D1.
- 025800 MOVE PU-SVB TO PU-D1.
- 025900 MOVE ALLOT-SVB TO ALLOT-D1.
- 026000 MOVE PASTR-SVB TO PASTR-D1.
- 026100 MOVE TRN-SVB TO TRN-D1.
- 026200 MOVE PCT-SWA-SVB TO PCT-SWA-D1.
- 026300 MOVE STRAT-SVB TO STRAT-D1.
- 026400 MOVE CLMTC-ADJ-FCTR-SVB TO CLMTC-ADJ-FCTR-D1.
- 026500 MOVE PCT-SLP-SVB TO PCT-SLP-D1.
- 026600 MOVE SLP-ASPT-SVB TO SLP-ASPT-D1.
- 026700 MOVE LND-FRM-SVB TO LND-FRM-D1.
- 026800 MOVE SOIL-PHS-SVB TO SOIL-PHS-D1.
- 026900* MOVE DATA FROM VC-RECORD
- 027000 MOVE RS-NUM-SVC TO RS-NUM-D1.
- 027100 MOVE COND-CL-SVC TO COND-CL-D1.
- 027200 MOVE VEG-SUB-TYP-SVC TO VEG-SUB-TYP-D1.
- 027300 WRITE VB1D-REC.
- 027400 MOVE SPACES TO VB1D-REC.
- 027500 ADD 1 TO VB1D-CNT.
- 027600 GO TO E620-RETURN.
- 027700 E680-FIND-MATCH.
- 027800 READ VC-SORT-OUT-FILE AT END
- 027900 DISPLAY "CURRENT VB FILE IS AT STRATUM #" STRAT-SVB
- 028000 DISPLAY "THERE ARE NO MORE STRATA ON THE VC FILE"
- 028100 GO TO E600-EXIT.
- 028200 IF STRAT-SVB > STRAT-SVC
- 028300 GO TO E680-FIND-MATCH.
- 028400 E600-EXIT.
- 028500 EXIT.
- 028600 DUMMY SECTION.
- 028700 D900-END.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES310U.
- 000300* INITIAL EDIT/UPDATE OF STRATIFICATION (VB) AND
- 000400* ECOLOGICAL SITE (VR) FORMATS.
- 000500*
- 000600 AUTHOR. CARLANDER.
- 000700 INSTALLATION. BLM.
- 000800 DATE-WRITTEN. AUGUST 1979.
- 000900*REMARKS. ERROR UPDATE OF STRATUM AND
- 001000* ECOLOGICAL SITE DESCRIPTION.
- 001100*
- 001200 ENVIRONMENT DIVISION.
- 001300 CONFIGURATION SECTION.
- 001400 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001500 OBJECT-COMPUTER. LEVEL-66-ASCII SEQUENCE IS EBCDIC.
- 001600 INPUT-OUTPUT SECTION.
- 001700 FILE-CONTROL.
- 001800 SELECT NEW-FILE ASSIGN D1
- 001900 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002000 SELECT TRAN-FILE ASSIGN I1
- 002100 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002200 SELECT OPTIONAL PREV-FILE ASSIGN I2
- 002300 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002400 SELECT SORT-FILE ASSIGN I1 I2 I3.
- 002500 DATA DIVISION.
- 002600 FILE SECTION.
- 002700 FD PREV-FILE
- 002800 CODE-SET IS GBCD
- 002900 LABEL RECORDS ARE STANDARD
- 003000 DATA RECORDS ARE VB1X-RCD VR1X-RCD VR2X-RCD VR3X-RCD.
- 003100 01 VB1X-RCD.
- 003200 02 REC-TYP-VB1X PIC X(02).
- 003300 02 FMT-NUM-VB1X PIC X(01).
- 003400 02 FMT-CD-VB1X PIC X(01).
- 003500 02 SDRP-VB1X.
- 003600 03 BLM-ADM-U-ST-VB1X PIC X(02).
- 003700 03 BLM-ADM-U-DIST-VB1X PIC X(02).
- 003800 03 BLM-ADM-U-RA-VB1X PIC X(02).
- 003900 03 BLM-ADM-U-PLU-VB1X PIC X(02).
- 004000 02 CLMTC-ADJ-FCTR-VB1X PIC X(05).
- 004100 02 DATA-DATE-VB1X PIC X(06).
- 004200 02 ACTN-CD-VB1X PIC X(01).
- 004300 02 LIN-NUM-VB1X PIC X(04).
- 004400 02 SWA-VB1X PIC X(04).
- 004500 02 TRN-NUM-VB1X PIC X(02).
- 004600 02 SWA-PCT-VB1X PIC X(03).
- 004700 02 RNG-SITE-ID-VB1X PIC X(11).
- 004800 02 STRATUM-NUM-VB1X PIC X(04).
- 004900 02 ALLOT-NUM-VB1X PIC X(04).
- 005000 02 PASTURE-NUM-VB1X PIC X(02).
- 005100 02 VEG-SUB-TYP-VB1X PIC X(04).
- 005200 02 RNG-ECOL-COND-CLS-VB1X PIC X(01).
- 005300 02 PCT-SPL-VB1X PIC X(03).
- 005400 02 ASPT-VB1X PIC X(02).
- 005500 02 L-FORM-VB1X PIC X(03).
- 005600 02 SOIL-PHAS-VB1X PIC X(05).
- 005700 02 FIL PIC X(20).
- 005800 01 VR1X-RCD.
- 005900 02 VR1X-CTL.
- 006000 03 REC-TYP-VR1X PIC X(02).
- 006100 03 FMT-NUM-CD-VR1X.
- 006200 05 FMT-NUM-VR1X PIC X(01).
- 006300 05 FMT-CD-VR1X PIC X(01).
- 006400 03 BLM-ADM-U-ST-VR1X PIC X(02).
- 006500 02 FIL PIC X(06).
- 006600 02 DATA-DATE-VR1X PIC X(06).
- 006700 02 ACTN-CD-VR1X PIC X(01).
- 006800 02 RNG-SITE-ID-VR1X PIC X(11).
- 006900 02 LIN-NUM-VR1X PIC X(04).
- 007000 02 RNG-SITE-NAM-VR1X PIC X(08).
- 007100 02 PRECIP-ZONE-VR1X PIC X(04).
- 007200 02 SSF-VAL-AVG-VR1X PIC X(03).
- 007300 02 POTN-PPA-RS-GRP-VR1X.
- 007400 03 POTN-PPA-RS-VR1X OCCURS 3 TIMES
- 007500 PIC X(06).
- 007600 02 FIL PIC X(29).
- 007700 01 VR2X-RCD.
- 007800 02 VR2X-CTL.
- 007900 03 REC-TYP-VR2X PIC X(02).
- 008000 03 FMT-NUM-CD-VR2X.
- 008100 05 FMT-NUM-VR2X PIC X(01).
- 008200 05 FMT-CD-VR2X PIC X(01).
- 008300 03 BLM-ADM-U-ST-VR2X PIC X(02).
- 008400 02 FIL PIC X(06).
- 008500 02 DATA-DATE-VR2X PIC X(06).
- 008600 02 ACTN-CD-VR2X PIC X(01).
- 008700 02 RNG-SITE-ID-VR2X PIC X(11).
- 008800 02 LIN-NUM-VR2X PIC X(04).
- 008900 02 PLANT-POTN-VR2X OCCURS 4 TIMES.
- 009000 03 PLANT-CD-VR2X PIC X(07).
- 009100 03 POTN-PPA-RS-PCT-VR2X PIC X(03).
- 009200 02 PLANT-TYP-VR2X PIC X(01) OCCURS 4 TIMES.
- 009300 02 FIL PIC X(18).
- 009400 01 VR3X-RCD.
- 009500 02 VR3X-CTL.
- 009600 03 REC-TYP-VR3X PIC X(02).
- 009700 03 FMT-NUM-VR3X PIC X(01).
- 009800 03 FMT-CD-VR3X PIC X(01).
- 009900 03 BLM-ADM-U-ST-VR3X PIC X(02).
- 010000 02 FIL PIC X(06).
- 010100 02 DATA-DATE-VR3X PIC X(06).
- 010200 02 ACTN-CD-VR3X PIC X(01).
- 010300 02 RNG-SITE-ID-VR3X PIC X(11).
- 010400 02 LIN-NUM-VR3X PIC X(04).
- 010500 02 SP-SN-VR3X OCCURS 2 TIMES.
- 010600 03 SOIL-PHAS-VR3X PIC X(05).
- 010700 03 SOIL-NAM-VR3X PIC X(24).
- 010800 02 FIL PIC X(04).
- 010900 FD TRAN-FILE
- 011000 CODE-SET IS GBCD
- 011100 LABEL RECORDS ARE STANDARD
- 011200 DATA RECORDS ARE REC-VB-TF REC-VR-TF.
- 011300 01 REC-VB-TF.
- 011400 03 REC-TYP-VB-TF PIC XX.
- 011500 03 FMT-NUM-CD-VB-TF PIC XX.
- 011600 03 ST-VB-TF PIC XX.
- 011700 03 DS-VB-TF PIC XX.
- 011800 03 RA-VB-TF PIC XX.
- 011900 03 PU-VB-TF PIC XX.
- 012000 03 CAF-VB-TF PIC X(5).
- 012100 03 FILLER PIC X(6).
- 012200 03 ACTN-VB-TF PIC X.
- 012300 03 LINE-VB-TF PIC XXXX.
- 012400 03 SWAT-VB-TF PIC X(6).
- 012500 03 SWA-PCT-VB-TF PIC XXX.
- 012600 03 RNG-SITE-VB-TF PIC X(11).
- 012700 03 STRATUM-VB-TF PIC XXXX.
- 012800 03 ALOT-VB-TF PIC XXXX.
- 012900 03 PAST-VB-TF PIC XX.
- 013000 03 FILLER PIC X(38).
- 013100 01 REC-VR-TF.
- 013200 03 FILLER PIC X(18).
- 013300 03 ACTN-VR-TF PIC X.
- 013400 03 RNG-SITE-VR-TF PIC X(11).
- 013500 03 LINE-VR-TF PIC XXXX.
- 013600 03 FILLER PIC X(62).
- 013700 FD NEW-FILE
- 013800 CODE-SET IS GBCD
- 013900 LABEL RECORDS ARE STANDARD
- 014000 DATA RECORDS ARE VB1Z-RCD VR1Z-RCD VR2Z-RCD VR3Z-RCD.
- 014100 01 VB1Z-RCD.
- 014200 02 REC-TYP-VB1Z PIC X(02).
- 014300 02 FMT-NUM-CD-VB1Z.
- 014400 03 FMT-NUM-VB1Z PIC X(01).
- 014500 03 FMT-CD-VB1Z PIC X(01).
- 014600 02 SDRP-VB1Z.
- 014700 03 BLM-ADM-U-ST-VB1Z PIC X(02).
- 014800 03 BLM-ADM-U-DIST-VB1Z PIC X(02).
- 014900 03 BLM-ADM-U-RA-VB1Z PIC X(02).
- 015000 03 BLM-ADM-U-PLU-VB1Z PIC X(02).
- 015100 02 CLMTC-ADJ-FCTR-VB1Z PIC X(05).
- 015200 02 DATA-DATE-VB1Z PIC X(06).
- 015300 02 ACTN-CD-VB1Z PIC X(01).
- 015400 02 LIN-NUM-VB1Z PIC X(04).
- 015500 02 SWA-VB1Z PIC X(04).
- 015600 02 TRN-NUM-VB1Z PIC X(02).
- 015700 02 SWA-PCT-VB1Z PIC X(03).
- 015800 02 RNG-SITE-ID-VB1Z PIC X(11).
- 015900 02 STRATUM-NUM-VB1Z PIC X(04).
- 016000 02 ALLOT-NUM-VB1Z PIC X(04).
- 016100 02 PASTURE-NUM-VB1Z PIC X(02).
- 016200 02 VEG-SUB-TYP-VB1Z PIC X(04).
- 016300 02 RNG-ECOL-COND-CLS-VB1Z PIC X(01).
- 016400 02 PCT-SPL-VB1Z PIC X(03).
- 016500 02 ASPT-VB1Z PIC X(02).
- 016600 02 L-FORM-VB1Z PIC X(03).
- 016700 02 SOIL-PHAS-VB1Z PIC X(05).
- 016800 02 FIL PIC X(20).
- 016900 01 VR1Z-RCD.
- 017000 02 VR1Z-CTL.
- 017100 03 REC-TYP-VR1Z PIC X(02).
- 017200 03 FMT-NUM-VR1Z PIC X(01).
- 017300 03 FMT-CD-VR1Z PIC X(01).
- 017400 03 BLM-ADM-U-ST-VR1Z PIC X(02).
- 017500 02 FIL PIC X(06).
- 017600 02 DATA-DATE-VR1Z PIC X(06).
- 017700 02 ACTN-CD-VR1Z PIC X(01).
- 017800 02 RNG-SITE-ID-VR1Z PIC X(11).
- 017900 02 LIN-NUM-VR1Z PIC X(04).
- 018000 02 RNG-SITE-NAM-VR1Z PIC X(08).
- 018100 02 PRECIP-ZONE-VR1Z PIC X(04).
- 018200 02 SSF-VAL-AVG-VR1Z PIC X(03).
- 018300 02 POTN-PPA-RS-GRP-VR1Z.
- 018400 03 POTN-PPA-RS-VR1Z OCCURS 3 TIMES
- 018500 PIC X(06).
- 018600 02 FIL PIC X(29).
- 018700 01 VR2Z-RCD.
- 018800 02 VR2Z-CTL.
- 018900 03 REC-TYP-VR2Z PIC X(02).
- 019000 03 FMT-NUM-VR2Z PIC X(01).
- 019100 03 FMT-CD-VR2Z PIC X(01).
- 019200 03 BLM-ADM-U-ST-VR2Z PIC X(02).
- 019300 02 FIL PIC X(06).
- 019400 02 DATA-DATE-VR2Z PIC X(06).
- 019500 02 ACTN-CD-VR2Z PIC X(01).
- 019600 02 RNG-SITE-ID-VR2Z PIC X(11).
- 019700 02 LIN-NUM-VR2Z PIC X(04).
- 019800 02 PLANT-POTN-VR2Z OCCURS 4 TIMES.
- 019900 03 PLANT-CD-VR2Z PIC X(07).
- 020000 03 POTN-PPA-RS-PCT-VR2Z PIC X(03).
- 020100 02 PLANT-TYP-VR2Z PIC X(01) OCCURS 4 TIMES.
- 020200 02 FIL PIC X(18).
- 020300 01 VR3Z-RCD.
- 020400 02 VR3Z-CTL.
- 020500 03 REC-TYP-VR3Z PIC X(02).
- 020600 03 FMT-NUM-VR3Z PIC X(01).
- 020700 03 FMT-CD-VR3Z PIC X(01).
- 020800 03 BLM-ADM-U-ST-VR3Z PIC X(02).
- 020900 02 FIL PIC X(06).
- 021000 02 DATA-DATE-VR3Z PIC X(06).
- 021100 02 ACTN-CD-VR3Z PIC X(01).
- 021200 02 RNG-SITE-ID-VR3Z PIC X(11).
- 021300 02 LIN-NUM-VR3Z PIC X(04).
- 021400 02 SP-SN-VR3Z OCCURS 2 TIMES.
- 021500 03 SOIL-PHAS-VR3Z PIC X(05).
- 021600 03 SOIL-NAM-VR3Z PIC X(24).
- 021700 02 FIL PIC X(04).
- 021800*
- 021900 SD SORT-FILE
- 022000 DATA RECORD IS SORT-REC.
- 022100 01 SORT-REC.
- 022200 02 SR-KEY.
- 022300 03 SORT-KEY-1.
- 022400 05 REC-TYP-SR PIC XX.
- 022500 05 ST-SR PIC XX.
- 022600 03 GROUP-VB-SR.
- 022700 05 SORT-KEY-2.
- 022800 07 LINE-CNTL-VB-SR.
- 022900 09 DS-VB-SR PIC XX.
- 023000 09 RA-VB-SR PIC XX.
- 023100 09 PU-VB-SR PIC XX.
- 023200 07 LINE-VB-SR PIC X(04).
- 023300 05 SORT-FIELDS-VB-SR.
- 023400 07 ALOT-VB-SR PIC XXXX.
- 023500 07 PAST-VB-SR PIC XX.
- 023600 07 SWAT-VB-SR PIC X(6).
- 023700 07 STRAT-VB-SR PIC XXXX.
- 023800 07 CAF-VB-SR PIC X(5).
- 023900 03 GROUP-VR-SR REDEFINES GROUP-VB-SR.
- 024000 05 SORT-KEY-3.
- 024100 07 LINE-CNTL-VR-SR.
- 024200 09 RNG-SITE-VR-SR PIC X(11).
- 024300 09 FMT-NUM-CD-VR-SR PIC XX.
- 024400 07 LINE-VR-SR PIC XXXX.
- 024500 05 FILLER PIC X(14).
- 024600 02 SR-DATA.
- 024700 03 SR-DATA-1.
- 024800 05 SR-RT PIC XXXX.
- 024900 05 FILLER PIC X(19).
- 025000 03 SR-DATA-2 PIC X(05).
- 025100 03 SR-DATA-3 PIC X(68).
- 025200 WORKING-STORAGE SECTION.
- 025300 77 END-OF-TRAN PIC X(01) VALUE " ".
- 025400 77 END-OF-PREV PIC X(01) VALUE " ".
- 025500 77 LAST-LIN-NUM PIC 9(04) VALUE 0000.
- 025600 77 DATE-SW PIC X(01).
- 025700 77 DATE-MV-SW PIC X(01).
- 025800 77 TODAYS-DATE PIC X(06).
- 025900 01 PARAMETER.
- 026000 03 RELINE-CHK PIC XXX.
- 026100 03 FILLER PIC X(77).
- 026200 01 CTRS.
- 026300 02 VB1-CTR PIC 99999 VALUE 0.
- 026400 02 VR1-CTR PIC 99999 VALUE 0.
- 026500 02 VR2-CTR PIC 99999 VALUE 0.
- 026600 02 VR3-CTR PIC 99999 VALUE 0.
- 026700 01 DATE-WORK.
- 026800 02 DW-YY PIC X(02).
- 026900 02 DW-MM PIC X(02).
- 027000 02 DW-DD PIC X(02).
- 027100 01 MOVED-DATE.
- 027200 02 MD-DD PIC XX.
- 027300 02 MD-YY PIC XX.
- 027400 02 MD-MM PIC XX.
- 027500 01 TRAN-CTL.
- 027600 03 TRAN-CTL-1.
- 027700 05 REC-TYP-TC PIC XX VALUE SPACES.
- 027800 05 FILLER PIC XX.
- 027900 03 GRP-VB-TC.
- 028000 05 TRAN-CTL-2 PIC X(10).
- 028100 05 FILLER-TC PIC X(7).
- 028200 03 GRP-VR-TC REDEFINES GRP-VB-TC.
- 028300 05 TRAN-CTL-3 PIC X(17).
- 028400 01 PREV-CTL.
- 028500 03 PREV-CNTL-1.
- 028600 05 REC-TYP-PC PIC XX.
- 028700 05 ST-PC PIC XX.
- 028800 03 GRP-VB-PC.
- 028900 05 PREV-CNTL-2.
- 029000 07 DS-VB-PC PIC XX.
- 029100 07 RA-VB-PC PIC XX.
- 029200 07 PU-VB-PC PIC XX.
- 029300 07 LINE-VB-PC PIC X(04).
- 029400 05 FILLER PIC X(7).
- 029500 03 GRP-VR-PC REDEFINES GRP-VB-PC.
- 029600 05 PREV-CNTL-3.
- 029700 07 RNG-SITE-VR-PC PIC X(11).
- 029800 07 FMT-NUM-CD-VR-PC PIC XX.
- 029900 07 LINE-VR-PC PIC XXXX.
- 030000 01 LINE-CTL.
- 030100 03 REC-LC PIC XX.
- 030200 03 SDRP-LC.
- 030300 05 ST-LC PIC XX.
- 030400 05 DS-LC PIC XX.
- 030500 05 RA-LC PIC XX.
- 030600 05 PU-LC PIC XX.
- 030700 03 RNG-SITE-LC PIC X(11).
- 030800 03 FMT-NUM-LC PIC X.
- 030900 01 LINE-CTL-HLD PIC X(22).
- 031000 01 VB1K-RCD.
- 031100 02 REC-TYP-VB1K PIC X(02).
- 031200 02 FMT-NUM-VB1K PIC X(01).
- 031300 02 FMT-CD-VB1K PIC X(01).
- 031400 02 SDRP-VB1K.
- 031500 03 BLM-ADM-U-ST-VB1K PIC X(02).
- 031600 03 BLM-ADM-U-DIST-VB1K PIC X(02).
- 031700 03 BLM-ADM-U-RA-VB1K PIC X(02).
- 031800 03 BLM-ADM-U-PLU-VB1K PIC X(02).
- 031900 02 CLMTC-ADJ-FCTR-VB1K PIC X(05).
- 032000 02 DATA-DATE-VB1K PIC X(06).
- 032100 02 ACTN-CD-VB1K PIC X(01).
- 032200 02 LIN-NUM-VB1K PIC X(04).
- 032300 02 SWA-VB1K PIC X(04).
- 032400 02 TRN-NUM-VB1K PIC X(02).
- 032500 02 SWA-PCT-VB1K PIC X(03).
- 032600 02 RNG-SITE-ID-VB1K PIC X(11).
- 032700 02 STRATUM-NUM-VB1K PIC X(04).
- 032800 02 ALLOT-NUM-VB1K PIC X(04).
- 032900 02 PASTURE-NUM-VB1K PIC X(02).
- 033000 02 VEG-SUB-TYP-VB1K PIC X(04).
- 033100 02 RNG-ECOL-COND-CLS-VB1K PIC X(01).
- 033200 02 PCT-SPL-VB1K PIC X(03).
- 033300 02 ASPT-VB1K PIC X(02).
- 033400 02 L-FORM-VB1K PIC X(03).
- 033500 02 SOIL-PHAS-VB1K PIC X(05).
- 033600 02 FIL PIC X(20).
- 033700 01 VR1K-RCD.
- 033800 02 VR1K-CTL.
- 033900 03 REC-TYP-VR1K PIC X(02).
- 034000 03 FMT-NUM-VR1K PIC X(01).
- 034100 03 FMT-CD-VR1K PIC X(01).
- 034200 03 BLM-ADM-U-ST-VR1K PIC X(02).
- 034300 02 FIL PIC X(06).
- 034400 02 DATA-DATE-VR1K PIC X(06).
- 034500 02 ACTN-CD-VR1K PIC X(01).
- 034600 02 RNG-SITE-ID-VR1K PIC X(11).
- 034700 02 LIN-NUM-VR1K PIC X(04).
- 034800 02 RNG-SITE-NAM-VR1K PIC X(08).
- 034900 02 PRECIP-ZONE-VR1K PIC X(04).
- 035000 02 SSF-VAL-AVG-VR1K PIC X(03).
- 035100 02 POTN-PPA-RS-GRP-VR1K.
- 035200 03 POTN-PPA-RS-VR1K OCCURS 3 TIMES
- 035300 PIC X(06).
- 035400 02 FIL PIC X(29).
- 035500 01 VR2K-RCD.
- 035600 02 VR2K-CTL.
- 035700 03 REC-TYP-VR2K PIC X(02).
- 035800 03 FMT-NUM-VR2K PIC X(01).
- 035900 03 FMT-CD-VR2K PIC X(01).
- 036000 03 BLM-ADM-U-ST-VR2K PIC X(02).
- 036100 02 FIL PIC X(06).
- 036200 02 DATA-DATE-VR2K PIC X(06).
- 036300 02 ACTN-CD-VR2K PIC X(01).
- 036400 02 RNG-SITE-ID-VR2K PIC X(11).
- 036500 02 LIN-NUM-VR2K PIC X(04).
- 036600 02 PLANT-POTN-VR2K OCCURS 4 TIMES.
- 036700 03 PLANT-CD-VR2K PIC X(07).
- 036800 03 POTN-PPA-RS-PCT-VR2K PIC X(03).
- 036900 02 PLANT-TYP-VR2K PIC X(01) OCCURS 4 TIMES.
- 037000 02 FIL PIC X(18).
- 037100 01 VR3K-RCD.
- 037200 02 VR3K-CTL.
- 037300 03 REC-TYP-VR3K PIC X(02).
- 037400 03 FMT-NUM-VR3K PIC X(01).
- 037500 03 FMT-CD-VR3K PIC X(01).
- 037600 03 BLM-ADM-U-ST-VR3K PIC X(02).
- 037700 02 FIL PIC X(06).
- 037800 02 DATA-DATE-VR3K PIC X(06).
- 037900 02 ACTN-CD-VR3K PIC X(01).
- 038000 02 RNG-SITE-ID-VR3K PIC X(11).
- 038100 02 LIN-NUM-VR3K PIC X(04).
- 038200 02 SP-SN-VR3K OCCURS 2 TIMES.
- 038300 03 SOIL-PHAS-VR3K PIC X(05).
- 038400 03 SOIL-NAM-VR3K PIC X(24).
- 038500 02 FIL PIC X(04).
- 038600 PROCEDURE DIVISION.
- 038700 000-DRIVER SECTION.
- 038800 010-MAINLINE.
- 038900 PERFORM 100-INITIALIZE.
- 039000 PERFORM 200-SORT.
- 039100 PERFORM 990-TERMINATE.
- 039200 STOP RUN.
- 039300*
- 039400 100-INITIALIZE SECTION.
- 039500 110-OPENS.
- 039600 OPEN INPUT PREV-FILE TRAN-FILE
- 039700 OUTPUT NEW-FILE.
- 039800 MOVE ALL "9" TO PREV-CTL.
- 039900 MOVE SPACE TO LINE-CTL LINE-CTL-HLD.
- 040000 ACCEPT TODAYS-DATE FROM DATE.
- 040100 ACCEPT PARAMETER.
- 040200*
- 040300 200-SORT SECTION.
- 040400 210-SORT-VERB.
- 040500 SORT SORT-FILE
- 040600 DESCENDING KEY REC-TYP-SR
- 040700 ASCENDING KEY ST-SR GROUP-VB-SR
- 040800 INPUT PROCEDURE 300-READ-FORMAT
- 040900 OUTPUT PROCEDURE 400-MATCH-UPDATE.
- 041000*
- 041100 300-READ-FORMAT SECTION.
- 041200 310-READ.
- 041300 READ TRAN-FILE
- 041400 AT END GO TO 300-EXIT.
- 041500 MOVE SPACE TO SR-KEY.
- 041600 MOVE REC-TYP-VB-TF TO REC-TYP-SR.
- 041700 MOVE ST-VB-TF TO ST-SR.
- 041800 IF (REC-TYP-VB-TF = "VB")
- 041900 AND (ACTN-VB-TF = SPACE)
- 042000 MOVE "A" TO ACTN-VB-TF.
- 042100 IF (REC-TYP-VB-TF = "VR")
- 042200 AND (ACTN-VR-TF = SPACE)
- 042300 MOVE "A" TO ACTN-VR-TF.
- 042400 IF REC-TYP-VB-TF = "VB"
- 042500 PERFORM 320-BUILD-VB-CTL
- 042600 ELSE
- 042700 PERFORM 330-BUILD-VR-CTL.
- 042800 RELEASE SORT-REC.
- 042900 GO TO 310-READ.
- 043000*
- 043100 320-BUILD-VB-CTL.
- 043200 MOVE DS-VB-TF TO DS-VB-SR.
- 043300 MOVE RA-VB-TF TO RA-VB-SR.
- 043400 MOVE PU-VB-TF TO PU-VB-SR.
- 043500 MOVE ALOT-VB-TF TO ALOT-VB-SR.
- 043600 MOVE PAST-VB-TF TO PAST-VB-SR.
- 043700 MOVE SWAT-VB-TF TO SWAT-VB-SR.
- 043800 MOVE STRATUM-VB-TF TO STRAT-VB-SR.
- 043900 MOVE CAF-VB-TF TO CAF-VB-SR.
- 044000 MOVE LINE-VB-TF TO LINE-VB-SR.
- 044100 IF (LINE-VB-SR = SPACES OR "0000")
- 044200 OR (RELINE-CHK = "YES")
- 044300 MOVE ALL "9" TO LINE-VB-SR, LINE-VB-TF.
- 044400 MOVE REC-VB-TF TO SR-DATA.
- 044500 330-BUILD-VR-CTL.
- 044600 MOVE FMT-NUM-CD-VB-TF TO FMT-NUM-CD-VR-SR.
- 044700 MOVE RNG-SITE-VR-TF TO RNG-SITE-VR-SR.
- 044800 MOVE LINE-VR-TF TO LINE-VR-SR.
- 044900 IF (LINE-VR-SR = SPACES OR "0000")
- 045000 OR (RELINE-CHK = "YES")
- 045100 MOVE ALL "9" TO LINE-VR-SR, LINE-VR-TF.
- 045200 MOVE REC-VR-TF TO SR-DATA.
- 045300 300-EXIT.
- 045400 EXIT.
- 045500*
- 045600 400-MATCH-UPDATE SECTION.
- 045700 410-GET-FIRST-RCDS.
- 045800 PERFORM 430-RETURN-SORT.
- 045900 PERFORM 440-READ-PREV.
- 046000 420-COMPARE.
- 046100 IF TRAN-CTL IS EQUAL TO ALL "9" AND
- 046200 PREV-CTL IS EQUAL TO ALL "9"
- 046300 GO TO 400-EXIT.
- 046400 IF TRAN-CTL IS GREATER THAN PREV-CTL
- 046500 PERFORM 500-NO-TRAN
- 046600 GO TO 420-COMPARE.
- 046700 IF PREV-CTL IS GREATER THAN TRAN-CTL
- 046800 PERFORM 600-NO-PREV
- 046900 GO TO 420-COMPARE.
- 047000 IF TRAN-CTL IS EQUAL TO PREV-CTL
- 047100 PERFORM 700-MATCH.
- 047200 GO TO 420-COMPARE.
- 047300 430-RETURN-SORT.
- 047400 RETURN SORT-FILE AT END
- 047500 MOVE "X" TO END-OF-TRAN.
- 047600 MOVE SORT-KEY-1 TO TRAN-CTL-1.
- 047700* IF END-OF-TRAN NOT = "X"
- 047800* DISPLAY SORT-REC.
- 047900 IF REC-TYP-SR IS EQUAL TO "VB"
- 048000 MOVE SR-DATA TO VB1K-RCD
- 048100 MOVE SPACE TO FILLER-TC
- 048200 MOVE SORT-KEY-2 TO TRAN-CTL-2 ELSE
- 048300 MOVE SORT-KEY-3 TO TRAN-CTL-3.
- 048400 IF SR-RT IS EQUAL TO "VR1D"
- 048500 MOVE SR-DATA TO VR1K-RCD.
- 048600 IF SR-RT IS EQUAL TO "VR2D"
- 048700 MOVE SR-DATA TO VR2K-RCD.
- 048800 IF SR-RT IS EQUAL TO "VR3D"
- 048900 MOVE SR-DATA TO VR3K-RCD.
- 049000 IF END-OF-TRAN IS EQUAL TO "X"
- 049100 MOVE ALL "9" TO TRAN-CTL.
- 049200 440-READ-PREV.
- 049300 READ PREV-FILE AT END
- 049400 MOVE "X" TO END-OF-PREV.
- 049500 IF END-OF-PREV NOT = "X"
- 049600 MOVE SPACE TO PREV-CTL.
- 049700 MOVE REC-TYP-VB1X TO REC-TYP-PC.
- 049800 MOVE BLM-ADM-U-ST-VB1X TO ST-PC.
- 049900 IF REC-TYP-VR2X = "VB"
- 050000 PERFORM 450-BUILD-VB-CTL
- 050100 ELSE
- 050200 PERFORM 460-BUILD-VR-CTL.
- 050300 IF END-OF-PREV = "X"
- 050400 MOVE ALL "9" TO PREV-CTL.
- 050500 450-BUILD-VB-CTL.
- 050600 MOVE BLM-ADM-U-DIST-VB1X TO DS-VB-PC.
- 050700 MOVE BLM-ADM-U-RA-VB1X TO RA-VB-PC.
- 050800 MOVE BLM-ADM-U-PLU-VB1X TO PU-VB-PC.
- 050900 MOVE LIN-NUM-VB1X TO LINE-VB-PC.
- 051000 460-BUILD-VR-CTL.
- 051100 MOVE RNG-SITE-ID-VR1X TO RNG-SITE-VR-PC.
- 051200 MOVE LIN-NUM-VR1X TO LINE-VR-PC.
- 051300 MOVE FMT-NUM-CD-VR1X TO FMT-NUM-CD-VR-PC.
- 051400*
- 051500 500-NO-TRAN.
- 051600 MOVE VB1X-RCD TO VB1Z-RCD.
- 051700 PERFORM 800-ADD-TO-CTRS.
- 051800 IF REC-TYP-VB1Z = "VB"
- 051900 PERFORM 830-CHECK-VB-LIN-NUM THRU 830-OUT
- 052000 MOVE LAST-LIN-NUM TO LIN-NUM-VB1Z
- 052100 ELSE
- 052200 PERFORM 840-CHECK-VR-LIN-NUM THRU 840-OUT
- 052300 MOVE LAST-LIN-NUM TO LIN-NUM-VR1Z.
- 052400 WRITE VB1Z-RCD.
- 052500 PERFORM 440-READ-PREV.
- 052600 600-NO-PREV.
- 052700 MOVE SR-DATA TO VB1Z-RCD.
- 052800 PERFORM 800-ADD-TO-CTRS.
- 052900 IF REC-TYP-VB1Z = "VB"
- 053000 PERFORM 830-CHECK-VB-LIN-NUM THRU 830-OUT
- 053100 MOVE LAST-LIN-NUM TO LIN-NUM-VB1Z
- 053200 ELSE
- 053300 PERFORM 840-CHECK-VR-LIN-NUM THRU 840-OUT
- 053400 MOVE LAST-LIN-NUM TO LIN-NUM-VR1Z.
- 053500 PERFORM 890-EDIT-DATE.
- 053600
- 053700 WRITE VB1Z-RCD.
- 053800 PERFORM 430-RETURN-SORT.
- 053900 700-MATCH.
- 054000 MOVE VB1X-RCD TO VB1Z-RCD.
- 054100 PERFORM 890-EDIT-DATE.
- 054200 IF SR-DATA-3 NOT = SPACES AND
- 054300 REC-TYP-VB1Z = "VB"
- 054400 PERFORM 850-MOVE-VB-FIELDS
- 054500 PERFORM 830-CHECK-VB-LIN-NUM THRU 830-OUT
- 054600 MOVE LAST-LIN-NUM TO LIN-NUM-VB1Z
- 054700 PERFORM 800-ADD-TO-CTRS
- 054800 MOVE "A" TO ACTN-CD-VB1Z
- 054900 WRITE VB1Z-RCD.
- 055000 IF SR-DATA-2 NOT = SPACES AND SR-DATA-3 NOT = SPACES AND
- 055100 REC-TYP-VB1Z = "VR" AND
- 055200 FMT-NUM-VB1Z = "1"
- 055300 PERFORM 860-MOVE-VR1-FIELDS
- 055400 PERFORM 840-CHECK-VR-LIN-NUM THRU 840-OUT
- 055500 MOVE LAST-LIN-NUM TO LIN-NUM-VR1Z
- 055600 PERFORM 800-ADD-TO-CTRS
- 055700 MOVE "A" TO ACTN-CD-VR1Z
- 055800 WRITE VB1Z-RCD.
- 055900 IF SR-DATA-2 NOT = SPACES AND SR-DATA-3 NOT = SPACES AND
- 056000 REC-TYP-VB1Z = "VR" AND
- 056100 FMT-NUM-VB1Z = "2"
- 056200 PERFORM 870-MOVE-VR2-FIELDS
- 056300 PERFORM 840-CHECK-VR-LIN-NUM THRU 840-OUT
- 056400 MOVE LAST-LIN-NUM TO LIN-NUM-VR1Z
- 056500 PERFORM 800-ADD-TO-CTRS
- 056600 MOVE "A" TO ACTN-CD-VR2Z
- 056700 WRITE VB1Z-RCD.
- 056800 IF SR-DATA-2 NOT = SPACES AND SR-DATA-3 NOT = SPACES AND
- 056900 REC-TYP-VB1X = "VR" AND
- 057000 FMT-NUM-VB1X = "3"
- 057100 PERFORM 880-MOVE-VR3-FIELDS
- 057200 PERFORM 840-CHECK-VR-LIN-NUM THRU 840-OUT
- 057300 MOVE LAST-LIN-NUM TO LIN-NUM-VR1Z
- 057400 PERFORM 800-ADD-TO-CTRS
- 057500 MOVE "A" TO ACTN-CD-VR3Z
- 057600 WRITE VB1Z-RCD.
- 057700 PERFORM 430-RETURN-SORT.
- 057800 PERFORM 440-READ-PREV.
- 057900 800-ADD-TO-CTRS.
- 058000 IF REC-TYP-VB1Z = "VB"
- 058100 ADD 1 TO VB1-CTR.
- 058200 IF REC-TYP-VB1Z = "VR" AND
- 058300 FMT-NUM-VB1Z = "1"
- 058400 ADD 1 TO VR1-CTR.
- 058500 IF REC-TYP-VB1Z = "VR" AND
- 058600 FMT-NUM-VB1Z = "2"
- 058700 ADD 1 TO VR2-CTR.
- 058800 IF REC-TYP-VB1Z = "VR" AND
- 058900 FMT-NUM-VB1Z = "3"
- 059000 ADD 1 TO VR3-CTR.
- 059100 810-BUILD-VB-LIN-NUM.
- 059200 IF (LIN-NUM-VB1Z NOT NUMERIC) OR
- 059300 (LIN-NUM-VB1Z = "0000")
- 059400 MOVE "9999" TO LIN-NUM-VB1Z.
- 059500 820-BUILD-VR-LIN-NUM.
- 059600 IF (LIN-NUM-VR1Z NOT NUMERIC) OR
- 059700 (LIN-NUM-VR1Z = "0000")
- 059800 MOVE "9999" TO LIN-NUM-VR1Z.
- 059900 830-CHECK-VB-LIN-NUM.
- 060000 MOVE SPACE TO LINE-CTL.
- 060100 MOVE REC-TYP-VB1Z TO REC-LC.
- 060200 MOVE SDRP-VB1Z TO SDRP-LC.
- 060300 IF LIN-NUM-VB1Z NOT = ALL "9"
- 060400 MOVE LINE-CTL TO LINE-CTL-HLD
- 060500 MOVE LIN-NUM-VB1Z TO LAST-LIN-NUM
- 060600 GO TO 830-OUT.
- 060700 IF LINE-CTL NOT = LINE-CTL-HLD
- 060800 MOVE LINE-CTL TO LINE-CTL-HLD
- 060900 MOVE 0001 TO LAST-LIN-NUM
- 061000 ELSE
- 061100 ADD 1 TO LAST-LIN-NUM.
- 061200 830-OUT.
- 061300 EXIT.
- 061400 840-CHECK-VR-LIN-NUM.
- 061500 MOVE SPACE TO LINE-CTL.
- 061600 MOVE REC-TYP-VR1Z TO REC-LC.
- 061700 MOVE BLM-ADM-U-ST-VR1Z TO ST-LC.
- 061800 MOVE RNG-SITE-ID-VR1Z TO RNG-SITE-LC.
- 061900 MOVE FMT-NUM-VR1Z TO FMT-NUM-LC.
- 062000 IF LIN-NUM-VR1Z NOT = ALL "9"
- 062100 MOVE LINE-CTL TO LINE-CTL-HLD
- 062200 MOVE LIN-NUM-VR1Z TO LAST-LIN-NUM
- 062300 GO TO 840-OUT.
- 062400 IF LINE-CTL NOT = LINE-CTL-HLD
- 062500 MOVE LINE-CTL TO LINE-CTL-HLD
- 062600 MOVE 0001 TO LAST-LIN-NUM
- 062700 ELSE
- 062800 ADD 1 TO LAST-LIN-NUM.
- 062900 840-OUT.
- 063000 EXIT.
- 063100*
- 063200 850-MOVE-VB-FIELDS.
- 063300 IF SWA-VB1K = SPACES
- 063400 NEXT SENTENCE
- 063500 ELSE
- 063600 IF SWA-VB1K = "****"
- 063700 MOVE SPACES TO SWA-VB1Z
- 063800 ELSE
- 063900 MOVE SWA-VB1K TO SWA-VB1Z.
- 064000 IF TRN-NUM-VB1K = SPACES
- 064100 NEXT SENTENCE
- 064200 ELSE
- 064300 IF TRN-NUM-VB1K = "**"
- 064400 MOVE SPACES TO TRN-NUM-VB1Z
- 064500 MOVE TRN-NUM-VB1K TO TRN-NUM-VB1Z.
- 064600 IF SWA-PCT-VB1K = SPACES
- 064700 NEXT SENTENCE
- 064800 ELSE
- 064900 IF SWA-PCT-VB1K = "***"
- 065000 MOVE SPACES TO SWA-PCT-VB1Z
- 065100 ELSE
- 065200 MOVE SWA-PCT-VB1K TO SWA-PCT-VB1Z.
- 065300 IF RNG-SITE-ID-VB1K = SPACES
- 065400 NEXT SENTENCE
- 065500 ELSE
- 065600 IF RNG-SITE-ID-VB1K = "***********"
- 065700 MOVE SPACES TO RNG-SITE-ID-VB1Z
- 065800 ELSE
- 065900 MOVE RNG-SITE-ID-VB1K TO RNG-SITE-ID-VB1Z.
- 066000 IF STRATUM-NUM-VB1K = "****"
- 066100 MOVE SPACES TO STRATUM-NUM-VB1Z STRATUM-NUM-VB1K.
- 066200 IF STRATUM-NUM-VB1K NOT = SPACES
- 066300 MOVE STRATUM-NUM-VB1K TO STRATUM-NUM-VB1Z.
- 066400 IF ALLOT-NUM-VB1K = SPACES
- 066500 NEXT SENTENCE
- 066600 ELSE
- 066700 IF ALLOT-NUM-VB1K = "****"
- 066800 MOVE SPACES TO ALLOT-NUM-VB1Z
- 066900 ELSE
- 067000 MOVE ALLOT-NUM-VB1K TO ALLOT-NUM-VB1Z.
- 067100 IF PASTURE-NUM-VB1K = SPACES
- 067200 NEXT SENTENCE
- 067300 ELSE
- 067400 IF PASTURE-NUM-VB1K = "**"
- 067500 MOVE SPACES TO PASTURE-NUM-VB1Z
- 067600 ELSE
- 067700 MOVE PASTURE-NUM-VB1K TO PASTURE-NUM-VB1Z.
- 067800 IF VEG-SUB-TYP-VB1K = SPACES
- 067900 NEXT SENTENCE
- 068000 ELSE
- 068100 IF VEG-SUB-TYP-VB1K = "****"
- 068200 MOVE SPACES TO VEG-SUB-TYP-VB1Z
- 068300 ELSE
- 068400 MOVE VEG-SUB-TYP-VB1K TO VEG-SUB-TYP-VB1Z.
- 068500 IF RNG-ECOL-COND-CLS-VB1K = SPACES
- 068600 NEXT SENTENCE
- 068700 ELSE
- 068800 IF RNG-ECOL-COND-CLS-VB1K = "*"
- 068900 MOVE SPACES TO RNG-ECOL-COND-CLS-VB1Z
- 069000 ELSE
- 069100 MOVE RNG-ECOL-COND-CLS-VB1K TO
- 069200 RNG-ECOL-COND-CLS-VB1Z.
- 069300 IF PCT-SPL-VB1K = SPACES
- 069400 NEXT SENTENCE
- 069500 ELSE
- 069600 IF PCT-SPL-VB1K = "***"
- 069700 MOVE SPACES TO PCT-SPL-VB1Z
- 069800 ELSE
- 069900 MOVE PCT-SPL-VB1K TO PCT-SPL-VB1Z.
- 070000 IF ASPT-VB1K = SPACES
- 070100 NEXT SENTENCE
- 070200 ELSE
- 070300 IF ASPT-VB1K = "**"
- 070400 MOVE SPACES TO ASPT-VB1Z
- 070500 ELSE
- 070600 MOVE ASPT-VB1K TO ASPT-VB1Z.
- 070700 IF L-FORM-VB1K = SPACES
- 070800 NEXT SENTENCE
- 070900 ELSE
- 071000 IF L-FORM-VB1K = "***"
- 071100 MOVE SPACES TO L-FORM-VB1Z
- 071200 ELSE
- 071300 MOVE L-FORM-VB1K TO L-FORM-VB1Z.
- 071400 IF SOIL-PHAS-VB1K = SPACES
- 071500 NEXT SENTENCE
- 071600 ELSE
- 071700 IF SOIL-PHAS-VB1K = "*****"
- 071800 MOVE SPACES TO SOIL-PHAS-VB1Z
- 071900 ELSE
- 072000 MOVE SOIL-PHAS-VB1K TO SOIL-PHAS-VB1Z.
- 072100 860-MOVE-VR1-FIELDS.
- 072200 IF RNG-SITE-NAM-VR1K = SPACES
- 072300 NEXT SENTENCE
- 072400 ELSE
- 072500 IF RNG-SITE-NAM-VR1K = "********"
- 072600 MOVE SPACES TO RNG-SITE-NAM-VR1Z
- 072700 ELSE
- 072800 MOVE RNG-SITE-NAM-VR1K TO RNG-SITE-NAM-VR1Z.
- 072900 IF PRECIP-ZONE-VR1K = SPACES
- 073000 NEXT SENTENCE
- 073100 ELSE
- 073200 IF PRECIP-ZONE-VR1K = "****"
- 073300 MOVE SPACES TO PRECIP-ZONE-VR1Z
- 073400 ELSE
- 073500 MOVE PRECIP-ZONE-VR1K TO PRECIP-ZONE-VR1Z.
- 073600 IF SSF-VAL-AVG-VR1K = SPACES
- 073700 NEXT SENTENCE
- 073800 ELSE
- 073900 IF SSF-VAL-AVG-VR1K = "***"
- 074000 MOVE SPACES TO SSF-VAL-AVG-VR1Z
- 074100 ELSE
- 074200 MOVE SSF-VAL-AVG-VR1K TO SSF-VAL-AVG-VR1Z.
- 074300 IF POTN-PPA-RS-VR1K (2) = SPACES
- 074400 NEXT SENTENCE
- 074500 ELSE
- 074600 IF POTN-PPA-RS-VR1K (2) = "******"
- 074700 MOVE SPACES TO POTN-PPA-RS-VR1Z (2)
- 074800 ELSE
- 074900 MOVE POTN-PPA-RS-VR1K (2) TO
- 075000 POTN-PPA-RS-VR1Z (2).
- 075100 IF POTN-PPA-RS-VR1K (3) = SPACES
- 075200 NEXT SENTENCE
- 075300 ELSE
- 075400 IF POTN-PPA-RS-VR1K (3) = "******"
- 075500 MOVE SPACES TO POTN-PPA-RS-VR1Z (3)
- 075600 ELSE
- 075700 MOVE POTN-PPA-RS-VR1K (3) TO
- 075800 POTN-PPA-RS-VR1Z (3).
- 075900 IF POTN-PPA-RS-VR1K (1) = SPACES
- 076000 NEXT SENTENCE
- 076100 ELSE
- 076200 IF POTN-PPA-RS-VR1K (1) = "******"
- 076300 MOVE SPACES TO POTN-PPA-RS-VR1Z (1)
- 076400 ELSE
- 076500 MOVE POTN-PPA-RS-VR1K (1) TO
- 076600 POTN-PPA-RS-VR1Z (1).
- 076700 870-MOVE-VR2-FIELDS.
- 076800 IF PLANT-CD-VR2K (1) = SPACES
- 076900 NEXT SENTENCE
- 077000 ELSE
- 077100 IF PLANT-CD-VR2K (1) = "*******"
- 077200 MOVE SPACES TO PLANT-CD-VR2Z (1)
- 077300 ELSE
- 077400 MOVE PLANT-CD-VR2K (1) TO PLANT-CD-VR2Z (1).
- 077500 IF POTN-PPA-RS-PCT-VR2K (1) = SPACES
- 077600 NEXT SENTENCE
- 077700 ELSE
- 077800 IF POTN-PPA-RS-PCT-VR2K (1) = "***"
- 077900 MOVE SPACES TO POTN-PPA-RS-PCT-VR2K (1)
- 078000 ELSE
- 078100 MOVE POTN-PPA-RS-PCT-VR2K (1) TO
- 078200 POTN-PPA-RS-PCT-VR2K (1).
- 078300 IF PLANT-CD-VR2K (2) = SPACES
- 078400 NEXT SENTENCE
- 078500 ELSE
- 078600 IF PLANT-CD-VR2K (2) = "*******"
- 078700 MOVE SPACES TO PLANT-CD-VR2Z (2)
- 078800 ELSE
- 078900 MOVE PLANT-CD-VR2K (2) TO PLANT-CD-VR2Z (2).
- 079000 IF POTN-PPA-RS-PCT-VR2K (2) = SPACES
- 079100 NEXT SENTENCE
- 079200 ELSE
- 079300 IF POTN-PPA-RS-PCT-VR2K (2) = "***"
- 079400 MOVE SPACES TO POTN-PPA-RS-PCT-VR2K (2)
- 079500 ELSE
- 079600 MOVE POTN-PPA-RS-PCT-VR2K (2) TO
- 079700 POTN-PPA-RS-PCT-VR2K (2).
- 079800 IF PLANT-CD-VR2K (3) = SPACES
- 079900 NEXT SENTENCE
- 080000 ELSE
- 080100 IF PLANT-CD-VR2K (3) = "*******"
- 080200 MOVE SPACES TO PLANT-CD-VR2Z (3)
- 080300 ELSE
- 080400 MOVE PLANT-CD-VR2K (3) TO PLANT-CD-VR2Z (3).
- 080500 IF POTN-PPA-RS-PCT-VR2K (3) = SPACES
- 080600 NEXT SENTENCE
- 080700 ELSE
- 080800 IF POTN-PPA-RS-PCT-VR2K (3) = "***"
- 080900 MOVE SPACES TO POTN-PPA-RS-PCT-VR2Z (3)
- 081000 ELSE
- 081100 MOVE POTN-PPA-RS-PCT-VR2K (3) TO
- 081200 POTN-PPA-RS-PCT-VR2Z (3).
- 081300 IF PLANT-TYP-VR2K (1) = SPACES
- 081400 NEXT SENTENCE
- 081500 ELSE
- 081600 IF PLANT-TYP-VR2K (1) = "*"
- 081700 MOVE SPACES TO PLANT-TYP-VR2Z (1)
- 081800 ELSE
- 081900 MOVE PLANT-TYP-VR2K (1) TO PLANT-TYP-VR2Z (1).
- 082000 IF PLANT-TYP-VR2K (2) = SPACES
- 082100 NEXT SENTENCE
- 082200 ELSE
- 082300 IF PLANT-TYP-VR2K (2) = "*"
- 082400 MOVE SPACES TO PLANT-TYP-VR2Z (2)
- 082500 ELSE
- 082600 MOVE PLANT-TYP-VR2K (2) TO PLANT-TYP-VR2Z (2).
- 082700 IF PLANT-TYP-VR2K (3) = SPACES
- 082800 NEXT SENTENCE
- 082900 ELSE
- 083000 IF PLANT-TYP-VR2K (3) = "*"
- 083100 MOVE SPACES TO PLANT-TYP-VR2Z (3)
- 083200 ELSE
- 083300 MOVE PLANT-TYP-VR2K (3) TO PLANT-TYP-VR2Z (3).
- 083400 IF PLANT-TYP-VR2K (4) = SPACES
- 083500 NEXT SENTENCE
- 083600 ELSE
- 083700 IF PLANT-TYP-VR2K (4) = "*"
- 083800 MOVE SPACES TO PLANT-TYP-VR2Z (4)
- 083900 ELSE
- 084000 MOVE PLANT-TYP-VR2K (4) TO PLANT-TYP-VR2Z (4).
- 084100 880-MOVE-VR3-FIELDS.
- 084200 IF SOIL-PHAS-VR3K (1) = SPACES
- 084300 NEXT SENTENCE
- 084400 ELSE
- 084500 IF SOIL-PHAS-VR3K (1) = "*****"
- 084600 MOVE SPACES TO SOIL-PHAS-VR3Z (1)
- 084700 ELSE
- 084800 MOVE SOIL-PHAS-VR3K (1) TO SOIL-PHAS-VR3Z (1).
- 084900 IF SOIL-NAM-VR3K (1) = SPACES
- 085000 NEXT SENTENCE
- 085100 ELSE
- 085200 IF SOIL-NAM-VR3K (1) = "*************************"
- 085300 MOVE SPACES TO SOIL-NAM-VR3Z (1)
- 085400 ELSE
- 085500 MOVE SOIL-NAM-VR3K (1) TO SOIL-NAM-VR3Z (1).
- 085600 IF SOIL-PHAS-VR3K (2) = SPACES
- 085700 NEXT SENTENCE
- 085800 ELSE
- 085900 IF SOIL-PHAS-VR3K (2) = "*****"
- 086000 MOVE SPACES TO SOIL-PHAS-VR3Z (2)
- 086100 ELSE
- 086200 MOVE SOIL-PHAS-VR3K (2) TO SOIL-PHAS-VR3Z (2).
- 086300 IF SOIL-NAM-VR3K (2) = SPACES
- 086400 NEXT SENTENCE
- 086500 ELSE
- 086600 IF SOIL-NAM-VR3K (2) = "*************************"
- 086700 MOVE SPACES TO SOIL-NAM-VR3Z (2)
- 086800 ELSE
- 086900 MOVE SOIL-NAM-VR3K (2) TO SOIL-NAM-VR3Z (2).
- 087000*
- 087100 890-EDIT-DATE.
- 087200 MOVE SPACE TO DATE-MV-SW.
- 087300 IF REC-TYP-VB1Z = "VB"
- 087400 MOVE DATA-DATE-VB1Z TO DATE-WORK
- 087500 ELSE
- 087600 MOVE DATA-DATE-VR1Z TO DATE-WORK.
- 087700 PERFORM 900-EDIT-FIELDS.
- 087800 IF DATE-SW NOT = " "
- 087900 PERFORM 910-SWITCH-FIELDS
- 088000 PERFORM 900-EDIT-FIELDS.
- 088100 IF DATE-SW NOT = " " AND
- 088200 REC-TYP-VB1Z = "VB"
- 088300 MOVE TODAYS-DATE TO DATA-DATE-VB1Z.
- 088400 IF DATE-SW NOT = " " AND
- 088500 REC-TYP-VB1Z = "VR"
- 088600 MOVE TODAYS-DATE TO DATA-DATE-VR1Z.
- 088700 IF DATE-MV-SW NOT = " " AND
- 088800 REC-TYP-VB1Z = "VB"
- 088900 MOVE MOVED-DATE TO DATA-DATE-VB1Z.
- 089000 IF DATE-MV-SW NOT = " " AND
- 089100 REC-TYP-VB1Z = "VR"
- 089200 MOVE MOVED-DATE TO DATA-DATE-VR1Z.
- 089300 900-EDIT-FIELDS.
- 089400 MOVE SPACE TO DATE-SW.
- 089500 IF DW-MM NOT NUMERIC OR
- 089600 DW-MM > "12" OR
- 089700 DW-MM < "01"
- 089800 MOVE "X" TO DATE-SW.
- 089900 IF DW-DD NOT NUMERIC OR
- 090000 DW-DD < "01" OR
- 090100 DW-DD > "31"
- 090200 MOVE "X" TO DATE-SW.
- 090300 IF DW-YY NOT NUMERIC OR
- 090400 DW-YY < "78"
- 090500 MOVE "X" TO DATE-SW.
- 090600 910-SWITCH-FIELDS.
- 090700 IF DW-DD = "78" OR "79" OR "80" OR "81" OR "82"
- 090800 MOVE DW-MM TO MD-MM
- 090900 MOVE DW-DD TO MD-DD
- 091000 MOVE DW-YY TO MD-YY
- 091100 MOVE "X" TO DATE-MV-SW.
- 091200 400-EXIT.
- 091300 EXIT.
- 091400*
- 091500 990-TERMINATE SECTION.
- 091600 990-PRINT.
- 091700 DISPLAY " VB1 VR1 VR2 VR3".
- 091800 DISPLAY VB1-CTR " " VR1-CTR " " VR2-CTR " " VR3-CTR.
- 091900 990-CLOSE.
- 092000 CLOSE PREV-FILE TRAN-FILE NEW-FILE.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES315P.
- 000300* VB / VR VERIFICATION LIST
- 000400*
- 000500 AUTHOR. CORA FISCHER.
- 000600 INSTALLATION.
- 000700 DATE-WRITTEN. 8/8/80.
- 000800 DATE-COMPILED.
- 000900 ENVIRONMENT DIVISION.
- 001000 CONFIGURATION SECTION.
- 001100 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001200 OBJECT-COMPUTER. LEVEL-66-ASCII.
- 001300 INPUT-OUTPUT SECTION.
- 001400 FILE-CONTROL.
- 001500 SELECT INPUT-FILE1 ASSIGN TO I1-ES310UD1
- 001600 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001700 SELECT PRINT-FILE ASSIGN TO P1-PRINTER
- 001800 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001900 SELECT SORT-FILE ASSIGN TO S1.
- 002000 DATA DIVISION.
- 002100 SUB-SCHEMA SECTION.
- 002200 DB CODVAL2 WITHIN BLMDIC.
- 002300 FILE SECTION.
- 002400 FD INPUT-FILE1 CODE-SET IS GBCD
- 002500 LABEL RECORDS ARE STANDARD
- 002600 DATA RECORDS ARE FDR-VB FDR-VR1
- 002700 FDR-VR2 FDR-VR3.
- 002800 01 FDR-VB.
- 002900 03 REC-TYPE-3529-VB-I1 PIC X(02).
- 003000 03 FMT-NO-3576-VB-I1 PIC X(01).
- 003100 03 FMT-CD-3579-VB-I1 PIC X(01).
- 003200 03 ADM-UNIT-0003-VB-I1.
- 003300 05 ADM-ST-0003-VB-I1 PIC X(02).
- 003400 05 ADM-DI-0003-VB-I1 PIC X(02).
- 003500 05 ADM-RA-0003-VB-I1 PIC X(02).
- 003600 05 ADM-PU-0003-VB-I1 PIC X(02).
- 003700 03 CLMTC-ADJ-FCTR-3547-VB-I1 PIC 99V999.
- 003800 03 DATA-DT-6618-VB-I1 PIC X(06).
- 003900 03 ACT-CD-7350-VB-I1 PIC X(01).
- 004000 03 LINE-NO-3578-VB-I1 PIC X(04).
- 004100 03 SWA-3507-VB-I1 PIC X(04).
- 004200 03 TRN-NUM-3508-VB-I1 PIC X(02).
- 004300 03 SWA-PCT-3516-VB-I1 PIC X(03).
- 004400 03 RNG-SITE-ID-3528-VB-I1 PIC X(11).
- 004500 03 STRATUM-NUM-3906-VB-I1 PIC 9(04).
- 004600 03 ALLOT-NUM-0968-VB-I1 PIC X(04).
- 004700 03 PASTURE-NUM-3905-VB-I1 PIC X(02).
- 004800 03 VEG-SUB-TYPE-2706-VB-I1 PIC X(04).
- 004900 03 RNG-ECOL-COND-CLS-2625-VB-I1 PIC X(01).
- 005000 03 PCT-SLP-3874-VB-I1 PIC X(03).
- 005100 03 ASPT-6523-VB-I1 PIC X(02).
- 005200 03 L-FORM-5132-VB-I1 PIC X(03).
- 005300 03 SOIL-PHAS-4649-VB-I1 PIC X(05).
- 005400 03 FILLER PIC X(20).
- 005500 01 FDR-VR1.
- 005600 03 REC-TYPE-3529-VR1-I1 PIC X(02).
- 005700 03 FMT-NO-3576-VR1-I1 PIC X(01).
- 005800 03 FMT-CD-3579-VR1-I1 PIC X(01).
- 005900 03 ADM-UNIT-0003-VR1-I1.
- 006000 05 ADM-ST-0003-VR1-I1 PIC X(02).
- 006100 05 ADM-DI-0003-VR1-I1 PIC X(02).
- 006200 05 ADM-RA-0003-VR1-I1 PIC X(02).
- 006300 05 ADM-PU-0003-VR1-I1 PIC X(02).
- 006400 03 DATA-DT-6618-VR1-I1 PIC X(06).
- 006500 03 ACT-CD-7350-VR1-I1 PIC X(01).
- 006600 03 RNG-SITE-ID-3528-VR1-I1 PIC X(11).
- 006700 03 FILLER PIC X(04).
- 006800 03 RNG-SITE-NAM-3914-VR1-I1 PIC X(08).
- 006900 03 PRECIP-ZONE-3909-VR1-I1.
- 007000 05 PRECIP-ZONE-LOW-3909-VR1-I1 PIC X(02).
- 007100 05 PRECIP-ZONE-HI-3909-VR1-I1 PIC X(02).
- 007200 03 SSF-VAL-AVG-4818-VR1-I1 PIC X(03).
- 007300 03 POTN-PPA-3930-VR1-I1 PIC X(06) OCCURS 3 TIMES.
- 007400 03 FILLER PIC X(29).
- 007500 01 FDR-VR2.
- 007600 03 REC-TYPE-3529-VR2-I1 PIC X(02).
- 007700 03 FMT-NO-3576-VR2-I1 PIC X(01).
- 007800 03 FMT-CD-3579-VR2-I1 PIC X(01).
- 007900 03 ADM-UNIT-0003-VR2-I1.
- 008000 05 ADM-ST-0003-VR2-I1 PIC X(02).
- 008100 05 ADM-DI-0003-VR2-I1 PIC X(02).
- 008200 05 ADM-RA-0003-VR2-I1 PIC X(02).
- 008300 05 ADM-PU-0003-VR2-I1 PIC X(02).
- 008400 03 DATA-DT-6618-VR2-I1 PIC X(06).
- 008500 03 ACT-CD-7350-VR2-I1 PIC X(01).
- 008600 03 RNG-SITE-ID-3528-VR2-I1 PIC X(11).
- 008700 03 LINE-NO-3578-VR2-I1 PIC X(04).
- 008800 03 PLANT-CD-POTN-PCT-VR2-I1 OCCURS 4 TIMES.
- 008900 05 PLANT-CD-2646-VR2-I1 PIC X(07).
- 009000 05 POTN-PCT-3535-VR2-I1 PIC X(03).
- 009100 01 FDR-VR3.
- 009200 03 REC-TYPE-3529-VR3-I1 PIC X(02).
- 009300 03 FMT-NO-3576-VR3-I1 PIC X(01).
- 009400 03 FMT-CD-3579-VR3-I1 PIC X(01).
- 009500 03 ADM-UNIT-0003-VR3-I1.
- 009600 05 ADM-ST-0003-VR3-I1 PIC X(02).
- 009700 05 ADM-DI-0003-VR3-I1 PIC X(02).
- 009800 05 ADM-RA-0003-VR3-I1 PIC X(02).
- 009900 05 ADM-PU-0003-VR3-I1 PIC X(02).
- 010000 03 DATA-DT-6618-VR3-I1 PIC X(06).
- 010100 03 ACT-CD-7350-VR3-I1 PIC X(01).
- 010200 03 RNG-SITE-ID-3528-VR3-I1 PIC X(11).
- 010300 03 LINE-NO-3578-VR3-I1 PIC X(04).
- 010400 03 SOIL-PHASE-NAME-VR3-I1 OCCURS 2 TIMES.
- 010500 05 SOIL-PHAS-4649-VR3-I1 PIC X(05).
- 010600 05 SOIL-NAM-4648-VR3-I1 PIC X(24).
- 010700 FD PRINT-FILE CODE-SET IS GBCD
- 010800 LABEL RECORDS ARE STANDARD
- 010900 DATA RECORD IS PRT-REC.
- 011000 01 PRT-REC PIC X(132).
- 011100 SD SORT-FILE DATA RECORDS ARE S-KEY1, S-KEY2,
- 011200 S-KEY3, S-KEY4.
- 011300 01 S-KEY1.
- 011400 03 SORT-KEY1-VB.
- 011500 04 S-KEY-1A.
- 011600 05 REC-TYPE-3529-VB-S1 PIC X(02).
- 011700 05 FMT-NO-3576-VB-S1 PIC X(01).
- 011800 05 FMT-CD-3579-VB-S1 PIC X(01).
- 011900 04 S-KEY-2A.
- 012000 05 ADM-UNIT-0003-VB-S1.
- 012100 07 ADM-ST-0003-VB-S1 PIC X(02).
- 012200 07 ADM-DI-0003-VB-S1 PIC X(02).
- 012300 07 ADM-RA-0003-VB-S1 PIC X(02).
- 012400 07 ADM-PU-0003-VB-S1 PIC X(02).
- 012500 05 ALLOT-NUM-0968-VB-S1 PIC X(04).
- 012600 05 PASTURE-NUM-3905-VB-S1 PIC X(02).
- 012700 05 SWA-3507-VB-S1 PIC X(04).
- 012800 05 TRN-NUM-3508-VB-S1 PIC X(02).
- 012900 05 STRATUM-NUM-3906-VB-S1 PIC 9(04).
- 013000 05 CLMTC-ADJ-FCTR-3547-VB-S1 PIC 99V999.
- 013100 03 SORT-KEY2-VB.
- 013200 05 DATA-DT-6618-VB-S1 PIC X(06).
- 013300 05 ACT-CD-7350-VB-S1 PIC X(01).
- 013400 05 LINE-NO-3578-VB-S1 PIC 9(04).
- 013500 05 SWA-PCT-3516-VB-S1 PIC X(03).
- 013600 05 RNG-SITE-ID-3528-VB-S1 PIC X(11).
- 013700 05 VEG-SUB-TYPE-2706-VB-S1 PIC X(04).
- 013800 05 RNG-ECOL-COND-CLS-2625-VB-S1 PIC X(01).
- 013900 05 PCT-SLP-3874-VB-S1 PIC X(03).
- 014000 05 ASPT-6523-VB-S1 PIC X(02).
- 014100 05 L-FORM-5132-VB-S1 PIC X(03).
- 014200 05 SOIL-PHAS-4649-VB-S1 PIC X(05).
- 014300 05 FILLER PIC X(26).
- 014400 01 S-KEY2.
- 014500 03 SORT-KEY1-VR1.
- 014600 05 REC-TYPE-3529-VR1-S1 PIC X(02).
- 014700 05 FILLER PIC X(01).
- 014800 05 FMT-CD-3579-VR1-S1 PIC X(01).
- 014900 05 ADM-ST-0003-VR1-S1 PIC X(02).
- 015000 05 RNG-SITE-ID-3528-VR1-S1 PIC X(11).
- 015100 05 FMT-NO-3576-VR1-S1 PIC X(01).
- 015200 05 FILLER PIC X(15).
- 015300 03 SORT-KEY2-VR1.
- 015400 05 DATA-DT-6618-VR1-S1 PIC X(06).
- 015500 05 ACT-CD-7350-VR1-S1 PIC X(01).
- 015600 05 RNG-SITE-NAM-3914-VR1-S1 PIC X(08).
- 015700 05 PRECIP-ZONE-3909-VR1-S1.
- 015800 07 PRECIP-ZONE-LOW-3909-VR1-S1 PIC X(02).
- 015900 07 PRECIP-ZONE-HI-3909-VR1-S1 PIC X(02).
- 016000 05 SSF-VAL-AVG-4818-VR1-S1 PIC X(03).
- 016100 05 POTN-PPA-3930-VR1-S1 PIC X(06)
- 016200 OCCURS 3 TIMES.
- 016300 05 FILLER PIC X(29).
- 016400 01 S-KEY3.
- 016500 03 SORT-KEY1-VR2.
- 016600 05 REC-TYPE-3529-VR2-S1 PIC X(02).
- 016700 05 FILLER PIC X(01).
- 016800 05 FMT-CD-3579-VR2-S1 PIC X(01).
- 016900 05 ADM-ST-0003-VR2-S1 PIC X(02).
- 017000 05 RNG-SITE-ID-3528-VR2-S1 PIC X(11).
- 017100 05 FMT-NO-3576-VR2-S1 PIC X(01).
- 017200 05 FILLER PIC X(15).
- 017300 03 SORT-KEY2-VR2.
- 017400 05 DATA-DT-6618-VR2-S1 PIC X(06).
- 017500 05 ACT-CD-7350-VR2-S1 PIC X(01).
- 017600 05 LINE-NO-3578-VR2-S1 PIC X(04).
- 017700 05 PLANT-CD-POTN-PCT-VR2-S1 OCCURS 4 TIMES.
- 017800 07 PLANT-CD-2646-VR2-S1 PIC X(07).
- 017900 07 POTN-PCT-3535-VR2-S1 PIC X(03).
- 018000 05 FILLER PIC X(18).
- 018100 01 S-KEY4.
- 018200 03 SORT-KEY1-VR3.
- 018300 05 REC-TYPE-3529-VR3-S1 PIC X(02).
- 018400 05 FILLER PIC X(01).
- 018500 05 FMT-CD-3579-VR3-S1 PIC X(01).
- 018600 05 ADM-ST-0003-VR3-S1 PIC X(02).
- 018700 05 RNG-SITE-ID-3528-VR3-S1 PIC X(11).
- 018800 05 FMT-NO-3576-VR3-S1 PIC X(01).
- 018900 05 FILLER PIC X(15).
- 019000 03 SORT-KEY2-VR3.
- 019100 05 DATA-DT-6618-VR3-S1 PIC X(06).
- 019200 05 ACT-CD-7350-VR3-S1 PIC X(01).
- 019300 05 LINE-NO-3578-VR3-S1 PIC 9(04).
- 019400 05 SOIL-PHASE-NAME-VR3-S1 OCCURS 2 TIMES.
- 019500 07 SOIL-PHAS-4649-VR3-S1 PIC X(05).
- 019600 07 SOIL-NAM-4648-VR3-S1 PIC X(24).
- 019700 WORKING-STORAGE SECTION.
- 019800 77 INPUT1-CNT PIC 9(07) VALUE 0.
- 019900 77 PAGE-CNT PIC 9(05) VALUE 0.
- 020000 77 VB-CNT PIC 9(07) VALUE 0.
- 020100 77 VR1-CNT PIC 9(07) VALUE 0.
- 020200 77 VR2-CNT PIC 9(07) VALUE 0.
- 020300 77 VR3-CNT PIC 9(07) VALUE 0.
- 020400 77 LINE-CNT PIC 9(02) VALUE 66.
- 020500 01 SW2-3 PIC 9(01) VALUE 0.
- 020600 01 VB-SW PIC 9 VALUE 0.
- 020700 01 SW-DET-VR2-3 PIC 9(01) VALUE 0.
- 020800 01 HLD-KEY-1A-S.
- 020900 03 H-REC-TYPE-S1 PIC X(02).
- 021000 03 H-FMT-NO-HLD-S1 PIC X(01).
- 021100 03 H-FMT-CD-HLD-S1 PIC X(01).
- 021200 01 H-RNG-SITE-NUM-S1 PIC X(11).
- 021300 01 HLD-REC-TYPE.
- 021400 03 REC-TYPE-HLD PIC X(02).
- 021500 03 FMT-NO-HLD PIC X(01).
- 021600 03 FMT-CD-HLD PIC X(01).
- 021700 01 HLD-RNG-SITE-NUM PIC X(11).
- 021800 01 MONTH-TABLE.
- 021900 03 MO-TAB.
- 022000 05 FILLER PIC X(03) VALUE "JAN".
- 022100 05 FILLER PIC X(03) VALUE "FEB".
- 022200 05 FILLER PIC X(03) VALUE "MAR".
- 022300 05 FILLER PIC X(03) VALUE "APR".
- 022400 05 FILLER PIC X(03) VALUE "MAY".
- 022500 05 FILLER PIC X(03) VALUE "JUN".
- 022600 05 FILLER PIC X(03) VALUE "JUL".
- 022700 05 FILLER PIC X(03) VALUE "AUG".
- 022800 05 FILLER PIC X(03) VALUE "SEP".
- 022900 05 FILLER PIC X(03) VALUE "OCT".
- 023000 05 FILLER PIC X(03) VALUE "NOV".
- 023100 05 FILLER PIC X(03) VALUE "DEC".
- 023200 03 MON REDEFINES MO-TAB PIC X(03) OCCURS 12 TIMES.
- 023300 01 EOF-SWITCH PIC 9 VALUE ZERO.
- 023400 88 EOF VALUE 1.
- 023500 01 EOR-SWITCH PIC 9 VALUE ZERO.
- 023600 88 EOR VALUE 1.
- 023700 01 PARAMETER PIC X(04).
- 023800 01 HLD-DT.
- 023900 03 HOLD-DT.
- 024000 05 YR-DT PIC XX.
- 024100 05 MO-DT PIC 99.
- 024200 05 DY-DT PIC XX.
- 024300 03 INV-HLD.
- 024400 05 INV-NM PIC X(20).
- 024500 05 ST-DIST-CD.
- 024600 07 ST-CD-HLD PIC X(02).
- 024700 07 DI-CD-HLD PIC X(02).
- 024800 03 EXPL-HLD.
- 024900 05 DIST-NM-HLD PIC X(12).
- 025000 03 FUNC-HLD.
- 025100 05 ST-NM-HLD PIC X(10).
- 025200 05 FILLER PIC X(14).
- 025300 COPY DBSTATUS IN TPCOBOLIB.
- 025400 01 HDR-1.
- 025500 03 FILLER PIC X(08) VALUE
- 025600 " DATE: ".
- 025700 03 HDR-MO PIC X(03).
- 025800 03 FILLER PIC X(01) VALUE SPACE.
- 025900 03 HDR-DA PIC X(02).
- 026000 03 FILLER PIC X(04) VALUE ", 19".
- 026100 03 HDR-YR PIC X(02).
- 026200 03 FILLER PIC X(21) VALUE SPACES.
- 026300 03 FILLER PIC X(47) VALUE
- 026400 "US DEPT OF INTERIOR - BUREAU OF LAND MANAGEMENT".
- 026500 03 FILLER PIC X(29) VALUE SPACES.
- 026600 03 FILLER PIC X(07) VALUE
- 026700 "PAGE: ".
- 026800 03 HDR-PG PIC ZZ,ZZ9.
- 026900 03 FILLER PIC X(02) VALUE SPACES.
- 027000 01 HDR-2.
- 027100 03 FILLER PIC X(8) VALUE
- 027200 "STATE: ".
- 027300 03 HDR-ST-CD PIC X(02).
- 027400 03 FILLER PIC X(04) VALUE SPACES.
- 027500 03 HDR-ST-NM PIC X(10).
- 027600 03 FILLER PIC X(30) VALUE SPACES.
- 027700 03 FILLER PIC X(25) VALUE
- 027800 "ECOLOGICAL SITE INVENTORY".
- 027900 03 FILLER PIC X(35) VALUE SPACES.
- 028000 03 FILLER PIC X(18) VALUE
- 028100 "PROGRAM: ES315P ".
- 028200 01 HDR-3.
- 028300 03 FILLER PIC X(08) VALUE
- 028400 " DI: ".
- 028500 03 HDR-DIST-CD PIC X(02).
- 028600 03 FILLER PIC X(04) VALUE SPACES.
- 028700 03 HDR-DIST-NM PIC X(25).
- 028800 03 FILER PIC X(79) VALUE SPACES.
- 028900 03 FILLER PIC X(14) VALUE
- 029000 "PCN: PCN315 ".
- 029100 01 HDR-4.
- 029200 03 FILLER PIC X(08) VALUE
- 029300 " INV: ".
- 029400 03 HDR-INV-CD PIC X(04).
- 029500 03 FILLER PIC X(02) VALUE SPACES.
- 029600 03 HDR-INV-NM PIC X(25).
- 029700 03 FILLER PIC X(16) VALUE SPACES.
- 029800 03 HDR-REC-TYPE PIC X(02).
- 029900 03 FILLER PIC X(18) VALUE
- 030000 " VERIFICATION LIST".
- 030100 03 FILLER PIC X(57) VALUE SPACES.
- 030200 01 HDR-5-VB.
- 030300 03 FILLER PIC X(16) VALUE
- 030400 "(1-2) (3)".
- 030500 03 FILLER PIC X(13) VALUE SPACES.
- 030600 03 FILLER PIC X(38) VALUE
- 030700 "(4) (5) (6) (7) (8) (9)".
- 030800 03 FILLER PIC X(53) VALUE
- 030900 " (10) (11) (12) (13) (14) (15) (16) (17)".
- 031000 03 FILLER PIC X(12) VALUE
- 031100 " (18) (19)".
- 031200 01 HDR-6-VB.
- 031300 03 FILLER PIC X(51) VALUE
- 031400 " REC ADMINISTRATIVE UNIT CLMTC DATE ACT LINE".
- 031500 03 FILLER PIC X(25) VALUE
- 031600 " SWA TRN PCT RANGE".
- 031700 03 FILLER PIC X(24) VALUE SPACES.
- 031800 03 FILLER PIC X(32) VALUE
- 031900 "VEG COND PCT LAND SOIL".
- 032000 01 HDR-7-VB.
- 032100 03 FILLER PIC X(51) VALUE
- 032200 "TYPE ST DI RA PU ADJFCTR YYMMDD CD NUM".
- 032300 03 FILLER PIC X(58) VALUE
- 032400 " NUM NUM SWA SITE STRAT ALLOT PAST SUBTYP CL ".
- 032500 03 FILLER PIC X(23) VALUE
- 032600 "SLOPE SLOPE FORM SER".
- 032700 01 HDR-8-VB.
- 032800 03 FILLER PIC X(52) VALUE
- 032900 " 1-4 5-6 7-8 9-10 11-12 13-17 18-23 24 25-28 ".
- 033000 03 FILLER PIC X(52) VALUE
- 033100 "29-32 33-4 35-7 38-48 49-52 53-56 57-58 59-62".
- 033200 03 FILLER PIC X(26) VALUE
- 033300 "63 64-66 67-68 69-71 72-76".
- 033400 01 HDR-9-VB.
- 033500 03 FILLER PIC X(53) VALUE
- 033600 "XXXX XX XX XX XX 99.999 XXXXXX X 9999 ".
- 033700 03 FILLER PIC X(53) VALUE
- 033800 "XXXX XX 999 XXXXXXXXXXX 9999 9999 99 9999 ".
- 033900 03 FILLER PIC X(26) VALUE
- 034000 "X 999 XX XXX XXXXX".
- 034100 01 HDR-10-DET-VB.
- 034200 03 REC-TYPE-3529-VB-P1 PIC X(02).
- 034300 03 FMT-NO-3576-VB-P1 PIC X(01).
- 034400 03 FMT-CD-3579-VB-P1 PIC X(01).
- 034500 03 FILLER PIC X(02) VALUE SPACES.
- 034600 03 ADM-ST-0003-VB-P1 PIC X(02).
- 034700 03 FILLER PIC X(03) VALUE SPACES.
- 034800 03 ADM-DI-0003-VB-P1 PIC X(02).
- 034900 03 FILLER PIC X(03) VALUE SPACES.
- 035000 03 ADM-RA-0003-VB-P1 PIC X(02).
- 035100 03 FILLER PIC X(03) VALUE SPACES.
- 035200 03 ADM-PU-0003-VB-P1 PIC X(02).
- 035300 03 FILLER PIC X(04) VALUE SPACES.
- 035400 03 CLMTC-ADJ-FCTR-3547-VB-P1 PIC 99.999.
- 035500 03 FILLER PIC X(02) VALUE SPACES.
- 035600 03 DATA-DT-6618-VB-P1 PIC X(06).
- 035700 03 FILLER PIC X(02) VALUE SPACES.
- 035800 03 ACT-CD-7350-VB-P1 PIC X(01).
- 035900 03 FILLER PIC X(03) VALUE SPACES.
- 036000 03 LINE-NO-3578-VB-P1 PIC X(04).
- 036100 03 FILLER PIC X(02) VALUE SPACES.
- 036200 03 SWA-3507-VB-P1 PIC X(04).
- 036300 03 FILLER PIC X(03) VALUE SPACES.
- 036400 03 TRN-NUM-3508-VB-P1 PIC X(02).
- 036500 03 FILLER PIC X(02) VALUE SPACES.
- 036600 03 SWA-PCT-3516-VB-P1 PIC X(03).
- 036700 03 FILLER PIC X(01) VALUE SPACE.
- 036800 03 RNG-SITE-ID-3528-VB-P1 PIC X(11).
- 036900 03 FILLER PIC X(02) VALUE SPACES.
- 037000 03 STRATUM-NUM-3906-VB-P1 PIC X(04).
- 037100 03 FILLER PIC X(02) VALUE SPACES.
- 037200 03 ALLOT-NUM-0968-VB-P1 PIC 9(04).
- 037300 03 FILLER PIC X(03) VALUE SPACES.
- 037400 03 PASTURE-NUM-3905-VB-P1 PIC 9(02).
- 037500 03 FILLER PIC X(04) VALUE SPACES.
- 037600 03 VEG-SUB-TYPE-2706-VB-P1 PIC X(04).
- 037700 03 FILLER PIC X(02) VALUE SPACES.
- 037800 03 RNG-ECOL-COND-CLS-2625-VB-P1 PIC X(01).
- 037900 03 FILLER PIC X(03) VALUE SPACES.
- 038000 03 PCT-SLP-3874-VB-P1 PIC X(03).
- 038100 03 FILLER PIC X(04) VALUE SPACES.
- 038200 03 ASPT-6523-VB-P1 PIC X(02).
- 038300 03 FILLER PIC X(03) VALUE SPACES.
- 038400 03 L-FORM-5132-VB-P1 PIC X(03).
- 038500 03 FILLER PIC X(02) VALUE SPACES.
- 038600 03 SOIL-PHAS-4649-VB-P1 PIC X(05).
- 038700 01 HDR-5-VR1.
- 038800 03 FILLER PIC X(52) VALUE
- 038900 "(1-2) (3) (4) (5) (6) ".
- 039000 03 FILLER PIC X(49) VALUE
- 039100 "(7) (8) (9) (10)".
- 039200 03 FILLER PIC X(31) VALUE SPACES.
- 039300 01 HDR-6-VR1.
- 039400 03 FILLER PIC X(51) VALUE
- 039500 " REC ADMIN DATE ACT RANGE SITE ".
- 039600 03 FILLER PIC X(22) VALUE
- 039700 "RANGE PRECIP ZONE".
- 039800 03 FILLER PIC X(15) VALUE SPACES.
- 039900 03 FILLER PIC X(20) VALUE
- 040000 "LBS OF PROD PER ACRE".
- 040100 03 FILLER PIC X(24) VALUE SPACES.
- 040200 01 HDR-7-VR1.
- 040300 03 FILLER PIC X(43) VALUE
- 040400 "TYPE ST YYMMDD CD NUMBER".
- 040500 03 FILLER PIC X(51) VALUE
- 040600 " SITE NAME LOW HI SSF AVG YR ".
- 040700 03 FILLER PIC X(24) VALUE
- 040800 " FVRBL YR UNFVRBL YR".
- 040900 03 FILLER PIC X(17) VALUE SPACES.
- 041000 01 HDR-8-VR1.
- 041100 03 FILLER PIC X(42) VALUE
- 041200 " 1-4 5-6 13-18 19 20-30".
- 041300 03 FILLER PIC X(48) VALUE
- 041400 " 35-42 43-4 45-6 47-9 50-55".
- 041500 03 FILLER PIC X(22) VALUE
- 041600 " 56-61 62-67".
- 041700 03 FILLER PIC X(20) VALUE SPACES.
- 041800 01 HDR-9-VR1.
- 041900 03 FILLER PIC X(49) VALUE
- 042000 "XXXX XX XXXXXX X XXXXXXXXXXX ".
- 042100 03 FILLER PIC X(46) VALUE
- 042200 "XXXXXXXX 99 99 999 999999 ".
- 042300 03 FILLER PIC X(18) VALUE
- 042400 "999999 999999".
- 042500 03 FILLER PIC X(19) VALUE SPACES.
- 042600 01 HDR-10-DET-VR1.
- 042700 03 REC-TYPE-3529-VR1-P1 PIC X(02).
- 042800 03 FMT-NO-3576-VR1-P1 PIC X(01).
- 042900 03 FMT-CD-3579-VR1-P1 PIC X(01).
- 043000 03 FILLER PIC X(06) VALUE SPACES.
- 043100 03 ADM-ST-0003-VR1-P1 PIC X(02).
- 043200 03 FILLER PIC X(05) VALUE SPACES.
- 043300 03 DATA-DT-6618-VR1-P1 PIC X(06).
- 043400 03 FILLER PIC X(05) VALUE SPACES.
- 043500 03 ACT-CD-7350-VR1-P1 PIC X(01).
- 043600 03 FILLER PIC X(05) VALUE SPACES.
- 043700 03 RNG-SITE-ID-3528-VR1-P1 PIC X(11).
- 043800 03 FILLER PIC X(04) VALUE SPACES.
- 043900 03 RNG-SITE-NAM-3914-VR1-P1 PIC X(08).
- 044000 03 FILLER PIC X(06) VALUE SPACES.
- 044100 03 PRECIP-ZONE-LOW-3909-VR1-P1 PIC X(02).
- 044200 03 FILLER PIC X(06) VALUE SPACES.
- 044300 03 PRECIP-ZONE-HI-3909-VR1-P1 PIC X(02).
- 044400 03 FILLER PIC X(05) VALUE SPACES.
- 044500 03 SSF-VAL-AVG-4818-VR1-P1 PIC X(03).
- 044600 03 FILLER PIC X(04) VALUE SPACES.
- 044700 03 POTN-PPA1-3930-VR1-P1 PIC X(06).
- 044800 03 FILLER PIC X(04) VALUE SPACES.
- 044900 03 POTN-PPA2-3930-VR1-P1 PIC X(06).
- 045000 03 FILLER PIC X(06) VALUE SPACES.
- 045100 03 POTN-PPA3-3930-VR1-P1 PIC X(06).
- 045200 03 FILLER PIC X(19) VALUE SPACES.
- 045300 01 HDR-5-VR2.
- 045400 03 FILLER PIC X(41) VALUE
- 045500 "(1-2) (3) (4) (5) (6)".
- 045600 03 FILLER PIC X(16) VALUE SPACES.
- 045700 03 FILLER PIC X(54) VALUE
- 045800 "(11) (12) (11) (12) (11) (12) ".
- 045900 03 FILLER PIC X(21) VALUE
- 046000 "(11) (12) ".
- 046100 01 HDR-6-VR2.
- 046200 03 FILLER PIC X(51) VALUE
- 046300 " REC ADMIN DATE ACT RANGE SITE LINE".
- 046400 03 FILLER PIC X(46) VALUE
- 046500 " PLANT PCT PLANT PCT PLANT".
- 046600 03 FILLER PIC X(35) VALUE
- 046700 " PCT PLANT PCT ".
- 046800 01 HDR-7-VR2.
- 046900 03 FILLER PIC X(48) VALUE
- 047000 "TYPE ST YYMMDD CD NUMBER ".
- 047100 03 FILLER PIC X(54) VALUE
- 047200 "NUM SYMBOL COMP SYMBOL COMP SYMBOL ".
- 047300 03 FILLER PIC X(22) VALUE
- 047400 "COMP SYMBOL COMP".
- 047500 03 FILLER PIC X(8) VALUE SPACES.
- 047600 01 HDR-8-VR2.
- 047700 03 FILLER PIC X(47) VALUE
- 047800 " 1-4 5-6 13-18 19 20-30 ".
- 047900 03 FILLER PIC X(50) VALUE
- 048000 "31-34 35-41 42-44 45-51 52-44 55-61".
- 048100 03 FILLER PIC X(35) VALUE
- 048200 " 62-64 65-71 72-74 ".
- 048300 01 HDR-9-VR2.
- 048400 03 FILLER PIC X(51) VALUE
- 048500 "XXXX XX XXXXXX X XXXXXXXXXXX 9999".
- 048600 03 FILLER PIC X(40) VALUE
- 048700 " XXXXXXX 999 XXXXXXX 999 ".
- 048800 03 FILLER PIC X(32) VALUE
- 048900 "XXXXXXX 999 XXXXXXX 999".
- 049000 03 FILLER PIC X(9) VALUE SPACES.
- 049100 01 HDR-10-DET-VR2.
- 049200 03 REC-TYPE-3529-VR2-P1 PIC X(02).
- 049300 03 FMT-NO-3576-VR2-P1 PIC X(01).
- 049400 03 FMT-CD-3579-VR2-P1 PIC X(01).
- 049500 03 FILLER PIC X(06) VALUE SPACES.
- 049600 03 ADM-ST-0003-VR2-P1 PIC X(02).
- 049700 03 FILLER PIC X(05) VALUE SPACES.
- 049800 03 DATA-DT-6618-VR2-P1 PIC X(06).
- 049900 03 FILLER PIC X(05) VALUE SPACES.
- 050000 03 ACT-CD-7350-VR2-P1 PIC X(01).
- 050100 03 FILLER PIC X(05) VALUE SPACES.
- 050200 03 RNG-SITE-ID-3528-VR2-P1 PIC X(11).
- 050300 03 FILLER PIC X(02) VALUE SPACES.
- 050400 03 LINE-NO-3578-VR2-P1 PIC X(04).
- 050500 03 FILLER PIC X(04) VALUE SPACES.
- 050600 03 PLANT-CD1-2646-VR2-P1 PIC X(07).
- 050700 03 FILLER PIC X(04) VALUE SPACES.
- 050800 03 POTN-PCT1-3535-VR2-P1 PIC X(03).
- 050900 03 FILLER PIC X(04) VALUE SPACES.
- 051000 03 PLANT-CD2-2646-VR2-P1 PIC X(07).
- 051100 03 FILLER PIC X(04) VALUE SPACES.
- 051200 03 POTN-PCT2-3535-VR2-P1 PIC X(03).
- 051300 03 FILLER PIC X(04) VALUE SPACES.
- 051400 03 PLANT-CD3-2646-VR2-P1 PIC X(07).
- 051500 03 FILLER PIC X(04) VALUE SPACES.
- 051600 03 POTN-PCT3-3535-VR2-P1 PIC X(03).
- 051700 03 FILLER PIC X(04) VALUE SPACES.
- 051800 03 PLANT-CD4-2646-VR2-P1 PIC X(07).
- 051900 03 FILLER PIC X(04) VALUE SPACES.
- 052000 03 POTN-PCT4-3535-VR2-P1 PIC X(03).
- 052100 03 FILLER PIC X(09) VALUE SPACES.
- 052200 01 HDR-5-VR3.
- 052300 03 FILLER PIC X(41) VALUE
- 052400 "(1-2) (3) (4) (5) (6)".
- 052500 03 FILLER PIC X(16) VALUE SPACES.
- 052600 03 FILLER PIC X(04) VALUE "(13)".
- 052700 03 FILLER PIC X(18) VALUE SPACES.
- 052800 03 FILLER PIC X(04) VALUE "(14)".
- 052900 03 FILLER PIC X(14) VALUE SPACES.
- 053000 03 FILLER PIC X(04) VALUE "(13)".
- 053100 03 FILLER PIC X(17) VALUE SPACES.
- 053200 03 FILLER PIC X(04) VALUE "(14)".
- 053300 03 FILLER PIC X(10) VALUE SPACES.
- 053400 01 HDR-6-VR3.
- 053500 03 FILLER PIC X(50) VALUE
- 053600 "REC ADMIN DATE ACT RANGE SITE LINE".
- 053700 03 FILLER PIC X(13) VALUE
- 053800 " PHASE OF".
- 053900 03 FILLER PIC X(32) VALUE SPACES.
- 054000 03 FILLER PIC X(13) VALUE
- 054100 " PHASE OF".
- 054200 03 FILLER PIC X(28) VALUE SPACES.
- 054300 01 HDR-7-VR3.
- 054400 03 FILLER PIC X(48) VALUE
- 054500 "TYPE ST YYMMDD CD NUMBER ".
- 054600 03 FILLER PIC X(38) VALUE
- 054700 "NUM SOIL SERIES SOIL NAME".
- 054800 03 FILLER PIC X(46) VALUE
- 054900 " SOIL SERIES SOIL NAME ".
- 055000 01 HDR-8-VR3.
- 055100 03 FILLER PIC X(52) VALUE
- 055200 " 1-4 5-6 13-18 19 20-30 31-34".
- 055300 03 FILLER PIC X(50) VALUE
- 055400 " 35-39 40-63 64-68".
- 055500 03 FILLER PIC X(30) VALUE
- 055600 " 69-92 ".
- 055700 01 HDR-9-VR3.
- 055800 03 FILLER PIC X(47) VALUE
- 055900 "XXXX XX XXXXXX X XXXXXXXXXXX ".
- 056000 03 FILLER PIC X(46) VALUE
- 056100 "9999 XXXXX XXXXXXXXXXXXXXXXXXXXXXXX".
- 056200 03 FILLER PIC X(39) VALUE
- 056300 " XXXXX XXXXXXXXXXXXXXXXXXXXXXXX".
- 056400 01 HDR-10-DET-VR3.
- 056500 03 REC-TYPE-3529-VR3-P1 PIC X(02).
- 056600 03 FMT-NO-3576-VR3-P1 PIC X(01).
- 056700 03 FMT-CD-3579-VR3-P1 PIC X(01).
- 056800 03 FILLER PIC X(06) VALUE SPACES.
- 056900 03 ADM-ST-0003-VR3-P1 PIC X(02).
- 057000 03 FILLER PIC X(05) VALUE SPACES.
- 057100 03 DATA-DT-6618-VR3-P1 PIC X(06).
- 057200 03 FILLER PIC X(05) VALUE SPACES.
- 057300 03 ACT-CD-7350-VR3-P1 PIC X(01).
- 057400 03 FILLER PIC X(05) VALUE SPACES.
- 057500 03 RNG-SITE-ID-3528-VR3-P1 PIC X(11).
- 057600 03 FILLER PIC X(02) VALUE SPACES.
- 057700 03 LINE-NO-3578-VR3-P1 PIC X(04).
- 057800 03 FILLER PIC X(06) VALUE SPACES.
- 057900 03 SOIL-PHAS1-4649-VR3-P1 PIC X(05).
- 058000 03 FILLER PIC X(07) VALUE SPACES.
- 058100 03 SOIL-NAM1-4648-VR3-P1 PIC X(24).
- 058200 03 FILLER PIC X(04) VALUE SPACES.
- 058300 03 SOIL-PHAS2-4649-VR3-P1 PIC X(05).
- 058400 03 FILLER PIC X(06) VALUE SPACES.
- 058500 03 SOIL-NAM2-4648-VR3-P1 PIC X(24).
- 058600 PROCEDURE DIVISION.
- 058700 START-SORT SECTION.
- 058800 100-SORT.
- 058900 SORT SORT-FILE ON ASCENDING SORT-KEY1-VB
- 059000 INPUT PROCEDURE PRE-SORT
- 059100 OUTPUT PROCEDURE POST-SORT.
- 059200 200-END-SECTION.
- 059300 FINISH DIC-DE.
- 059400 DISPLAY "VB-CNT " VB-CNT.
- 059500 DISPLAY "VR1-CNT " VR1-CNT.
- 059600 DISPLAY "VR2-CNT " VR2-CNT.
- 059700 DISPLAY "VR3-CNT " VR3-CNT.
- 059800 CLOSE PRINT-FILE.
- 059900 STOP RUN.
- 060000 PRE-SORT SECTION.
- 060100 300-HSKPNG.
- 060200 OPEN INPUT INPUT-FILE1.
- 060300 MOVE SPACES TO S-KEY1 S-KEY2 S-KEY3 S-KEY4.
- 060400 400-MAIN.
- 060500 PERFORM 500-RD-FILE1 THRU 600-EXIT-RD-FL1 UNTIL EOF.
- 060600 CLOSE INPUT-FILE1.
- 060700 GO TO 960-EXIT-VR3.
- 060800 500-RD-FILE1.
- 060900 READ INPUT-FILE1 AT END MOVE 1 TO EOF-SWITCH.
- 061000 IF (EOF-SWITCH = 1) GO TO 600-EXIT-RD-FL1.
- 061100 ADD 1 TO INPUT1-CNT.
- 061200 IF REC-TYPE-3529-VB-I1 = "VB"
- 061300 PERFORM 700-MV-VB-TO-SRT THRU 750-EXIT-VB
- 061400 GO TO 600-EXIT-RD-FL1.
- 061500 IF REC-TYPE-3529-VB-I1 = "VR" AND FMT-NO-3576-VB-I1 = "1"
- 061600 PERFORM 900-MV-VR1-TO-SRT THRU 920-EXIT-VR1
- 061700 GO TO 600-EXIT-RD-FL1.
- 061800 IF REC-TYPE-3529-VR2-I1 = "VR" AND FMT-NO-3576-VR1-I1 = "2"
- 061900 PERFORM 930-MV-VR2-TO-SRT THRU 940-EXIT-VR2
- 062000 GO TO 600-EXIT-RD-FL1.
- 062100 IF REC-TYPE-3529-VR3-I1 = "VR" AND FMT-NO-3576-VR1-I1 = "3"
- 062200 PERFORM 950-MV-VR3-TO-SRT THRU 960-EXIT-VR3
- 062300 GO TO 600-EXIT-RD-FL1.
- 062400 600-EXIT-RD-FL1.
- 062500 EXIT.
- 062600 700-MV-VB-TO-SRT.
- 062700 ADD 1 TO VB-CNT.
- 062800 MOVE REC-TYPE-3529-VB-I1 TO REC-TYPE-3529-VB-S1.
- 062900 MOVE FMT-NO-3576-VB-I1 TO FMT-NO-3576-VB-S1.
- 063000 MOVE FMT-CD-3579-VB-I1 TO FMT-CD-3579-VB-S1.
- 063100 MOVE ADM-UNIT-0003-VB-I1 TO ADM-UNIT-0003-VB-S1.
- 063200 MOVE CLMTC-ADJ-FCTR-3547-VB-I1 TO CLMTC-ADJ-FCTR-3547-VB-S1.
- 063300 MOVE DATA-DT-6618-VB-I1 TO DATA-DT-6618-VB-S1.
- 063400 MOVE ACT-CD-7350-VB-I1 TO ACT-CD-7350-VB-S1.
- 063500 MOVE LINE-NO-3578-VB-I1 TO LINE-NO-3578-VB-S1.
- 063600 MOVE SWA-3507-VB-I1 TO SWA-3507-VB-S1.
- 063700 MOVE ALLOT-NUM-0968-VB-I1 TO ALLOT-NUM-0968-VB-S1.
- 063800 MOVE PASTURE-NUM-3905-VB-I1 TO PASTURE-NUM-3905-VB-S1.
- 063900 MOVE SWA-PCT-3516-VB-I1 TO SWA-PCT-3516-VB-S1.
- 064000 MOVE RNG-SITE-ID-3528-VB-I1 TO RNG-SITE-ID-3528-VB-S1.
- 064100 MOVE VEG-SUB-TYPE-2706-VB-I1 TO VEG-SUB-TYPE-2706-VB-S1.
- 064200 MOVE RNG-ECOL-COND-CLS-2625-VB-I1 TO
- 064300 RNG-ECOL-COND-CLS-2625-VB-S1.
- 064400 MOVE PCT-SLP-3874-VB-I1 TO PCT-SLP-3874-VB-S1.
- 064500 MOVE ASPT-6523-VB-I1 TO ASPT-6523-VB-S1.
- 064600 MOVE L-FORM-5132-VB-I1 TO L-FORM-5132-VB-S1.
- 064700 MOVE SOIL-PHAS-4649-VB-I1 TO SOIL-PHAS-4649-VB-S1.
- 064800 MOVE TRN-NUM-3508-VB-I1 TO TRN-NUM-3508-VB-S1.
- 064900 MOVE STRATUM-NUM-3906-VB-I1 TO STRATUM-NUM-3906-VB-S1.
- 065000 MOVE CLMTC-ADJ-FCTR-3547-VB-I1 TO CLMTC-ADJ-FCTR-3547-VB-S1.
- 065100 RELEASE S-KEY1.
- 065200 750-EXIT-VB.
- 065300 EXIT.
- 065400 900-MV-VR1-TO-SRT.
- 065500 ADD 1 TO VR1-CNT.
- 065600 MOVE REC-TYPE-3529-VR1-I1 TO REC-TYPE-3529-VR1-S1.
- 065700 MOVE FMT-NO-3576-VR1-I1 TO FMT-NO-3576-VR1-S1.
- 065800 MOVE FMT-CD-3579-VR1-I1 TO FMT-CD-3579-VR1-S1.
- 065900 MOVE ADM-ST-0003-VR1-I1 TO ADM-ST-0003-VR1-S1.
- 066000 MOVE DATA-DT-6618-VR1-I1 TO DATA-DT-6618-VR1-S1.
- 066100 MOVE ACT-CD-7350-VR1-I1 TO ACT-CD-7350-VR1-S1.
- 066200 MOVE RNG-SITE-ID-3528-VR1-I1 TO RNG-SITE-ID-3528-VR1-S1.
- 066300 MOVE RNG-SITE-NAM-3914-VR1-I1 TO RNG-SITE-NAM-3914-VR1-S1.
- 066400 MOVE PRECIP-ZONE-3909-VR1-I1 TO PRECIP-ZONE-3909-VR1-S1.
- 066500 MOVE SSF-VAL-AVG-4818-VR1-I1 TO SSF-VAL-AVG-4818-VR1-S1.
- 066600 MOVE POTN-PPA-3930-VR1-I1(1) TO POTN-PPA-3930-VR1-S1(1).
- 066700 MOVE POTN-PPA-3930-VR1-I1(2) TO POTN-PPA-3930-VR1-S1(2).
- 066800 MOVE POTN-PPA-3930-VR1-I1(3) TO POTN-PPA-3930-VR1-S1(3).
- 066900 RELEASE S-KEY2.
- 067000 920-EXIT-VR1.
- 067100 EXIT.
- 067200 930-MV-VR2-TO-SRT.
- 067300 ADD 1 TO VR2-CNT.
- 067400 MOVE REC-TYPE-3529-VR2-I1 TO REC-TYPE-3529-VR2-S1.
- 067500 MOVE FMT-NO-3576-VR2-I1 TO FMT-NO-3576-VR2-S1.
- 067600 MOVE FMT-CD-3579-VR2-I1 TO FMT-CD-3579-VR2-S1.
- 067700 MOVE ADM-ST-0003-VR2-I1 TO ADM-ST-0003-VR2-S1.
- 067800 MOVE DATA-DT-6618-VR2-I1 TO DATA-DT-6618-VR2-S1.
- 067900 MOVE ACT-CD-7350-VR2-I1 TO ACT-CD-7350-VR2-S1.
- 068000 MOVE RNG-SITE-ID-3528-VR2-I1 TO RNG-SITE-ID-3528-VR2-S1.
- 068100 MOVE LINE-NO-3578-VR2-I1 TO LINE-NO-3578-VR2-S1.
- 068200 MOVE PLANT-CD-POTN-PCT-VR2-I1(1) TO
- 068300 PLANT-CD-POTN-PCT-VR2-S1(1).
- 068400 MOVE PLANT-CD-POTN-PCT-VR2-I1(2) TO
- 068500 PLANT-CD-POTN-PCT-VR2-S1(2).
- 068600 MOVE PLANT-CD-POTN-PCT-VR2-I1(3) TO
- 068700 PLANT-CD-POTN-PCT-VR2-S1(3).
- 068800 MOVE PLANT-CD-POTN-PCT-VR2-I1(4) TO
- 068900 PLANT-CD-POTN-PCT-VR2-S1(4).
- 069000 RELEASE S-KEY3.
- 069100 940-EXIT-VR2.
- 069200 EXIT.
- 069300 950-MV-VR3-TO-SRT.
- 069400 ADD 1 TO VR3-CNT.
- 069500 MOVE REC-TYPE-3529-VR3-I1 TO REC-TYPE-3529-VR3-S1.
- 069600 MOVE FMT-NO-3576-VR3-I1 TO FMT-NO-3576-VR3-S1.
- 069700 MOVE FMT-CD-3579-VR3-I1 TO FMT-CD-3579-VR3-S1.
- 069800 MOVE ADM-ST-0003-VR3-I1 TO ADM-ST-0003-VR3-S1.
- 069900 MOVE DATA-DT-6618-VR3-I1 TO DATA-DT-6618-VR3-S1.
- 070000 MOVE ACT-CD-7350-VR3-I1 TO ACT-CD-7350-VR3-S1.
- 070100 MOVE RNG-SITE-ID-3528-VR3-I1 TO RNG-SITE-ID-3528-VR3-S1.
- 070200 MOVE FMT-NO-3576-VR3-I1 TO FMT-NO-3576-VR3-S1.
- 070300 MOVE LINE-NO-3578-VR3-I1 TO LINE-NO-3578-VR3-S1.
- 070400 MOVE SOIL-PHASE-NAME-VR3-I1(1) TO SOIL-PHASE-NAME-VR3-S1(1).
- 070500 MOVE SOIL-PHASE-NAME-VR3-I1(2) TO SOIL-PHASE-NAME-VR3-S1(2).
- 070600 RELEASE S-KEY4.
- 070700 960-EXIT-VR3.
- 070800 EXIT.
- 070900 POST-SORT SECTION.
- 071000 3050-RET-HSKPNG.
- 071100 OPEN OUTPUT PRINT-FILE.
- 071200 ACCEPT PARAMETER.
- 071300 ACCEPT HOLD-DT FROM DATE.
- 071400 MOVE YR-DT TO HDR-YR.
- 071500 MOVE MON(MO-DT) TO HDR-MO.
- 071600 MOVE DY-DT TO HDR-DA.
- 071700 READY DIC-DE.
- 071800 PERFORM 4000-VALIDATE-INV THRU 4050-EXIT-STDI.
- 071900 3060-RET.
- 072000 RETURN SORT-FILE AT END MOVE 1 TO EOR-SWITCH.
- 072100 IF REC-TYPE-3529-VB-S1 = "VB"
- 072200 MOVE 1 TO VB-SW.
- 072300 PERFORM 4460-CHK-WH-REC THRU 4470-EXIT-WH-REC.
- 072400 PERFORM 4100-CHK-LINE-CNT THRU 4150-EXIT-LINE-OVR50.
- 072500 3070-MAIN-DRIVER.
- 072600 MOVE 1 TO VB-SW.
- 072700 PERFORM 4300-DET-REC-LINE THRU 4350-EXIT-DET UNTIL EOR.
- 072800 GO TO 4830-DUMMY.
- 072900 4000-VALIDATE-INV.
- 073000 MOVE PARAMETER TO DE-CD-8822-DEC HDR-INV-CD.
- 073100 MOVE 3940 TO DE-NO-8801-DEC.
- 073200 FIND ANY CODE-DEC.
- 073300 MOVE DB-STATUS TO DB-STAT.
- 073400 IF NOT OK
- 073500 MOVE "UNKNOWN" TO HDR-ST-NM HDR-DIST-NM HDR-INV-NM
- 073600 GO TO 4050-EXIT-STDI.
- 073700 GET CODE-DEC.
- 073800 MOVE DB-STATUS TO DB-STAT.
- 073900 IF NOT OK
- 074000 DISPLAY "ES315PBD DIDN'T GET INVN"
- 074100 DISPLAY DB-STAT
- 074200 GO TO 4050-EXIT-STDI.
- 074300 MOVE DE-CD-NAM-8823-DEC TO INV-HLD.
- 074400 MOVE INV-NM TO HDR-INV-NM.
- 074500 4005-VALIDATE-ST.
- 074600 MOVE ST-CD-HLD TO DE-CD-8822-DEC HDR-ST-CD.
- 074700 MOVE 0003 TO DE-NO-8801-DEC.
- 074800 FIND ANY CODE-DEC.
- 074900 MOVE DB-STATUS TO DB-STAT.
- 075000 IF NOT OK
- 075100 MOVE "UNKNOWN" TO HDR-ST-NM
- 075200 GO TO 4008-EXIT-ST.
- 075300 GET CODE-DEC.
- 075400 MOVE DB-STATUS TO DB-STAT.
- 075500 IF NOT OK
- 075600 DISPLAY "ES315PBD 3 DIDN'T GET ST"
- 075700 DISPLAY "ES315PBD 4 " DB-STAT
- 075800 GO TO 4008-EXIT-ST.
- 075900 MOVE DE-CD-NAM-8823-DEC TO FUNC-HLD.
- 076000 MOVE ST-NM-HLD TO HDR-ST-NM.
- 076100 4008-EXIT-ST.
- 076200 EXIT.
- 076300 4010-VALIDATE-STDI.
- 076400 MOVE ST-DIST-CD TO DE-CD-8822-DEC.
- 076500 MOVE DI-CD-HLD TO HDR-DIST-CD.
- 076600 MOVE 0003 TO DE-NO-8801-DEC.
- 076700 FIND ANY CODE-DEC.
- 076800 MOVE DB-STATUS TO DB-STAT.
- 076900 IF NOT OK
- 077000 MOVE "UNKNOWN" TO HDR-DIST-NM
- 077100 GO TO 4050-EXIT-STDI.
- 077200 GET CODE-DEC.
- 077300 MOVE DB-STATUS TO DB-STAT.
- 077400 IF NOT OK
- 077500 DISPLAY "ES315PBD 5 DIDN'T GET STDI"
- 077600 DISPLAY "ES315PBD 6 " DB-STAT
- 077700 GO TO 4050-EXIT-STDI.
- 077800 FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
- 077900 MOVE DB-STATUS TO DB-STAT.
- 078000 IF NOT OK
- 078100 MOVE "UNKNOWN" TO HDR-DIST-NM
- 078200 GO TO 4050-EXIT-STDI.
- 078300 GET CODE-EXPL-DECE.
- 078400 MOVE DB-STATUS TO DB-STAT.
- 078500 IF NOT OK
- 078600 DISPLAY "ES315PBD 7 DIDN'T GET DIST"
- 078700 DISPLAY "ES315PBD 8 " DB-STAT
- 078800 GO TO 4050-EXIT-STDI.
- 078900 MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HLD
- 079000 MOVE DIST-NM-HLD TO HDR-DIST-NM.
- 079100 4050-EXIT-STDI.
- 079200 EXIT.
- 079300 4100-CHK-LINE-CNT.
- 079400 IF VB-SW = 0 GO TO 4150-EXIT-LINE-OVR50.
- 079500 IF LINE-CNT > 50 OR (HLD-REC-TYPE = "VR2D" OR "VR3D")
- 079600 PERFORM 4200-PRT-HDNG THRU 4250-HDNG-EXIT
- 079700 GO TO 4150-EXIT-LINE-OVR50.
- 079800 4150-EXIT-LINE-OVR50.
- 079900 EXIT.
- 080000 4200-PRT-HDNG.
- 080100 IF (HLD-REC-TYPE = "VB1D" OR "VR1D")
- 080200 PERFORM 4210-START-HDR THRU 4228-EXIT-HDR-VR2-3
- 080300 GO TO 4230-PRT-SPACES.
- 080400 IF (LINE-CNT > 50 AND SW2-3 = 1) OR
- 080500 (LINE-CNT > 50)
- 080600 MOVE 1 TO SW2-3
- 080700 MOVE 1 TO SW-DET-VR2-3
- 080800 PERFORM 4210-START-HDR THRU 4228-EXIT-HDR-VR2-3
- 080900 GO TO 4230-PRT-SPACES.
- 081000 IF (SW2-3 = 1)
- 081100 MOVE 0 TO SW2-3
- 081200 PERFORM 4222-CHK-VR THRU 4228-EXIT-HDR-VR2-3
- 081300 MOVE 0 TO SW-DET-VR2-3
- 081400 GO TO 4230-PRT-SPACES.
- 081500 GO TO 4230-PRT-SPACES.
- 081600 4210-START-HDR.
- 081700 ADD 1 TO PAGE-CNT.
- 081800 MOVE PAGE-CNT TO HDR-PG.
- 081900 WRITE PRT-REC FROM HDR-1 AFTER ADVANCING PAGE.
- 082000 WRITE PRT-REC FROM HDR-2 AFTER ADVANCING 1 LINES.
- 082100 WRITE PRT-REC FROM HDR-3 AFTER ADVANCING 1 LINES.
- 082200 MOVE 2 TO LINE-CNT.
- 082300 4220-CHK-WHAT-REC.
- 082400 IF HLD-REC-TYPE = "VB1D"
- 082500 MOVE "VB" TO HDR-REC-TYPE
- 082600 WRITE PRT-REC FROM HDR-4 AFTER ADVANCING 1 LINES
- 082700 WRITE PRT-REC FROM HDR-5-VB AFTER ADVANCING 2 LINES
- 082800 WRITE PRT-REC FROM HDR-6-VB AFTER ADVANCING 1 LINES
- 082900 WRITE PRT-REC FROM HDR-7-VB AFTER ADVANCING 1 LINES
- 083000 WRITE PRT-REC FROM HDR-8-VB AFTER ADVANCING 1 LINES
- 083100 WRITE PRT-REC FROM HDR-9-VB AFTER ADVANCING 1 LINES
- 083200 ADD 7 TO LINE-CNT
- 083300 GO TO 4228-EXIT-HDR-VR2-3.
- 083400 4222-CHK-VR.
- 083500 IF (REC-TYPE-HLD = "VR" AND SW2-3 = 1)
- 083600 MOVE "VR" TO HDR-REC-TYPE
- 083700 WRITE PRT-REC FROM HDR-4 AFTER ADVANCING 1 LINES
- 083800 ADD 1 TO LINE-CNT.
- 083900 IF SW-DET-VR2-3 = 1 NEXT SENTENCE
- 084000 ELSE GO TO 4228-EXIT-HDR-VR2-3.
- 084100 IF HLD-REC-TYPE = "VR1D"
- 084200 WRITE PRT-REC FROM HDR-5-VR1 AFTER ADVANCING 2 LINES
- 084300 WRITE PRT-REC FROM HDR-6-VR1 AFTER ADVANCING 1 LINES
- 084400 WRITE PRT-REC FROM HDR-7-VR1 AFTER ADVANCING 1 LINES
- 084500 WRITE PRT-REC FROM HDR-8-VR1 AFTER ADVANCING 1 LINES
- 084600 WRITE PRT-REC FROM HDR-9-VR1 AFTER ADVANCING 1 LINES
- 084700 ADD 6 TO LINE-CNT
- 084800 GO TO 4228-EXIT-HDR-VR2-3.
- 084900 4225-CHK-VR2-3.
- 085000 IF HLD-REC-TYPE = "VR2D"
- 085100 WRITE PRT-REC FROM HDR-5-VR2 AFTER ADVANCING 2 LINES
- 085200 WRITE PRT-REC FROM HDR-6-VR2 AFTER ADVANCING 1 LINES
- 085300 WRITE PRT-REC FROM HDR-7-VR2 AFTER ADVANCING 1 LINES
- 085400 WRITE PRT-REC FROM HDR-8-VR2 AFTER ADVANCING 1 LINES
- 085500 WRITE PRT-REC FROM HDR-9-VR2 AFTER ADVANCING 1 LINES
- 085600 ADD 6 TO LINE-CNT
- 085700 GO TO 4228-EXIT-HDR-VR2-3.
- 085800 IF HLD-REC-TYPE = "VR3D"
- 085900 WRITE PRT-REC FROM HDR-5-VR3 AFTER ADVANCING 2 LINES
- 086000 WRITE PRT-REC FROM HDR-6-VR3 AFTER ADVANCING 1 LINES
- 086100 WRITE PRT-REC FROM HDR-7-VR3 AFTER ADVANCING 1 LINES
- 086200 WRITE PRT-REC FROM HDR-8-VR3 AFTER ADVANCING 1 LINES
- 086300 WRITE PRT-REC FROM HDR-9-VR3 AFTER ADVANCING 1 LINES
- 086400 ADD 6 TO LINE-CNT
- 086500 GO TO 4228-EXIT-HDR-VR2-3.
- 086600 4228-EXIT-HDR-VR2-3.
- 086700 EXIT.
- 086800 4230-PRT-SPACES.
- 086900 IF SW-DET-VR2-3 = 0 GO TO 4250-HDNG-EXIT.
- 087000 MOVE SPACES TO PRT-REC.
- 087100 WRITE PRT-REC AFTER ADVANCING 1 LINES.
- 087200 ADD 1 TO LINE-CNT.
- 087300 4250-HDNG-EXIT.
- 087400 EXIT.
- 087500 4300-DET-REC-LINE.
- 087600 IF S-KEY-1A = "VB1D"
- 087700 MOVE S-KEY-1A TO HLD-KEY-1A-S
- 087800 ELSE
- 087900 MOVE REC-TYPE-3529-VR1-S1 TO H-REC-TYPE-S1
- 088000 MOVE FMT-NO-3576-VR1-S1 TO H-FMT-NO-HLD-S1
- 088100 MOVE FMT-CD-3579-VR1-S1 TO H-FMT-CD-HLD-S1
- 088200 MOVE RNG-SITE-ID-3528-VR1-S1 TO H-RNG-SITE-NUM-S1.
- 088300 IF (HLD-KEY-1A-S NOT = HLD-REC-TYPE)
- 088400 OR (HLD-KEY-1A-S = "VR1D" AND HLD-REC-TYPE = "VR1D")
- 088500 GO TO 4305-NOT-EQ.
- 088600 MOVE 0 TO SW2-3
- 088700 MOVE 0 TO SW-DET-VR2-3
- 088800 PERFORM 4400-PRNT-DET-LINE THRU 4450-EXIT-CHK-REC-TYP
- 088900 GO TO 4320-RET-SORT.
- 089000 4305-NOT-EQ.
- 089100 IF S-KEY-1A = "9999" GO TO 4350-EXIT-DET.
- 089200 IF (HLD-REC-TYPE = "VB1D") AND (REC-TYPE-3529-VR2-S1 = "VR"
- 089300 AND FMT-NO-3576-VR1-S1 = "1")
- 089400 MOVE 0 TO PAGE-CNT.
- 089500 IF (H-RNG-SITE-NUM-S1 NOT = HLD-RNG-SITE-NUM)
- 089600 MOVE 66 TO LINE-CNT.
- 089700 PERFORM 4460-CHK-WH-REC THRU 4470-EXIT-WH-REC.
- 089800 IF (HLD-REC-TYPE = "VB1D" OR "VR1D")
- 089900 MOVE 66 TO LINE-CNT.
- 090000 MOVE "1" TO SW2-3.
- 090100 MOVE 1 TO SW-DET-VR2-3
- 090200 PERFORM 4400-PRNT-DET-LINE THRU 4450-EXIT-CHK-REC-TYP.
- 090300 4320-RET-SORT.
- 090400 RETURN SORT-FILE AT END MOVE 1 TO EOR-SWITCH
- 090500 MOVE "9999" TO S-KEY-1A.
- 090600 IF EOR-SWITCH = 1 GO TO 4350-EXIT-DET.
- 090700 4350-EXIT-DET.
- 090800 EXIT.
- 090900 4400-PRNT-DET-LINE.
- 091000 PERFORM 4100-CHK-LINE-CNT THRU 4150-EXIT-LINE-OVR50.
- 091100 IF S-KEY-1A = "VB1D"
- 091200 PERFORM 4500-PRNT-VB THRU 4800-EXIT-PRT-DET
- 091300 GO TO 4450-EXIT-CHK-REC-TYP.
- 091400 IF REC-TYPE-3529-VR1-S1 = "VR" AND FMT-NO-3576-VR1-S1 = "1"
- 091500 PERFORM 4550-PRNT-VR1 THRU 4800-EXIT-PRT-DET
- 091600 GO TO 4450-EXIT-CHK-REC-TYP.
- 091700 4410-CHK-2-3.
- 091800 IF REC-TYPE-3529-VR2-S1 = "VR" AND FMT-NO-3576-VR2-S1 = "2"
- 091900 PERFORM 4600-PRNT-VR2 THRU 4800-EXIT-PRT-DET
- 092000 GO TO 4450-EXIT-CHK-REC-TYP.
- 092100 IF REC-TYPE-3529-VR3-S1 = "VR" AND FMT-NO-3576-VR3-S1 = "3"
- 092200 PERFORM 4650-PRNT-VR3 THRU 4800-EXIT-PRT-DET
- 092300 GO TO 4450-EXIT-CHK-REC-TYP.
- 092400 4450-EXIT-CHK-REC-TYP.
- 092500 EXIT.
- 092600 4460-CHK-WH-REC.
- 092700 IF S-KEY-1A = "VB1D"
- 092800 MOVE REC-TYPE-3529-VB-S1 TO REC-TYPE-HLD
- 092900 MOVE FMT-NO-3576-VB-S1 TO FMT-NO-HLD
- 093000 MOVE FMT-CD-3579-VB-S1 TO FMT-CD-HLD
- 093100 GO TO 4470-EXIT-WH-REC.
- 093200 IF (REC-TYPE-3529-VR1-S1 = "VR") AND
- 093300 (FMT-NO-3576-VR1-S1 = "1"
- 093400 OR "2" OR "3")
- 093500 MOVE REC-TYPE-3529-VR1-S1 TO HLD-REC-TYPE
- 093600 MOVE FMT-NO-3576-VR1-S1 TO FMT-NO-HLD
- 093700 MOVE FMT-CD-3579-VR1-S1 TO FMT-CD-HLD
- 093800 MOVE RNG-SITE-ID-3528-VR1-S1 TO
- 093900 HLD-RNG-SITE-NUM.
- 094000 4470-EXIT-WH-REC.
- 094100 EXIT.
- 094200 4500-PRNT-VB.
- 094300 MOVE REC-TYPE-3529-VB-S1 TO REC-TYPE-3529-VB-P1.
- 094400 MOVE FMT-NO-3576-VB-S1 TO FMT-NO-3576-VB-P1.
- 094500 MOVE FMT-CD-3579-VB-S1 TO FMT-CD-3579-VB-P1.
- 094600 MOVE ADM-ST-0003-VB-S1 TO ADM-ST-0003-VB-P1.
- 094700 MOVE ADM-DI-0003-VB-S1 TO ADM-DI-0003-VB-P1.
- 094800 MOVE ADM-RA-0003-VB-S1 TO ADM-RA-0003-VB-P1.
- 094900 MOVE ADM-PU-0003-VB-S1 TO ADM-PU-0003-VB-P1.
- 095000 MOVE CLMTC-ADJ-FCTR-3547-VB-S1 TO CLMTC-ADJ-FCTR-3547-VB-P1.
- 095100 MOVE DATA-DT-6618-VB-S1 TO DATA-DT-6618-VB-P1.
- 095200 MOVE ACT-CD-7350-VB-S1 TO ACT-CD-7350-VB-P1.
- 095300 MOVE LINE-NO-3578-VB-S1 TO LINE-NO-3578-VB-P1.
- 095400 MOVE SWA-3507-VB-S1 TO SWA-3507-VB-P1.
- 095500 MOVE TRN-NUM-3508-VB-S1 TO TRN-NUM-3508-VB-P1.
- 095600 MOVE SWA-PCT-3516-VB-S1 TO SWA-PCT-3516-VB-P1.
- 095700 MOVE RNG-SITE-ID-3528-VB-S1 TO RNG-SITE-ID-3528-VB-P1.
- 095800 MOVE STRATUM-NUM-3906-VB-S1 TO STRATUM-NUM-3906-VB-P1.
- 095900 MOVE ALLOT-NUM-0968-VB-S1 TO ALLOT-NUM-0968-VB-P1.
- 096000 MOVE PASTURE-NUM-3905-VB-S1 TO PASTURE-NUM-3905-VB-P1.
- 096100 MOVE VEG-SUB-TYPE-2706-VB-S1 TO VEG-SUB-TYPE-2706-VB-P1.
- 096200 MOVE RNG-ECOL-COND-CLS-2625-VB-S1 TO
- 096300 RNG-ECOL-COND-CLS-2625-VB-P1.
- 096400 MOVE PCT-SLP-3874-VB-S1 TO PCT-SLP-3874-VB-P1.
- 096500 MOVE ASPT-6523-VB-S1 TO ASPT-6523-VB-P1.
- 096600 MOVE L-FORM-5132-VB-S1 TO L-FORM-5132-VB-P1.
- 096700 MOVE SOIL-PHAS-4649-VB-S1 TO SOIL-PHAS-4649-VB-P1.
- 096800 WRITE PRT-REC FROM HDR-10-DET-VB AFTER ADVANCING 2 LINES.
- 096900 ADD 2 TO LINE-CNT.
- 097000 GO TO 4800-EXIT-PRT-DET.
- 097100 4550-PRNT-VR1.
- 097200 MOVE REC-TYPE-3529-VR1-S1 TO REC-TYPE-3529-VR1-P1.
- 097300 MOVE FMT-NO-3576-VR1-S1 TO FMT-NO-3576-VR1-P1.
- 097400 MOVE FMT-CD-3579-VR1-S1 TO FMT-CD-3579-VR1-P1.
- 097500 MOVE ADM-ST-0003-VR1-S1 TO ADM-ST-0003-VR1-P1.
- 097600 MOVE DATA-DT-6618-VR1-S1 TO DATA-DT-6618-VR1-P1.
- 097700 MOVE ACT-CD-7350-VR1-S1 TO ACT-CD-7350-VR1-P1.
- 097800 MOVE RNG-SITE-ID-3528-VR1-S1 TO RNG-SITE-ID-3528-VR1-P1.
- 097900 MOVE RNG-SITE-NAM-3914-VR1-S1 TO RNG-SITE-NAM-3914-VR1-P1.
- 098000 MOVE PRECIP-ZONE-LOW-3909-VR1-S1 TO
- 098100 PRECIP-ZONE-LOW-3909-VR1-P1.
- 098200 MOVE PRECIP-ZONE-HI-3909-VR1-S1 TO
- 098300 PRECIP-ZONE-HI-3909-VR1-P1.
- 098400 MOVE SSF-VAL-AVG-4818-VR1-S1 TO SSF-VAL-AVG-4818-VR1-P1.
- 098500 MOVE POTN-PPA-3930-VR1-S1(1) TO POTN-PPA1-3930-VR1-P1.
- 098600 MOVE POTN-PPA-3930-VR1-S1(2) TO POTN-PPA2-3930-VR1-P1.
- 098700 MOVE POTN-PPA-3930-VR1-S1(3) TO POTN-PPA3-3930-VR1-P1.
- 098800 WRITE PRT-REC FROM HDR-10-DET-VR1 AFTER ADVANCING 2 LINES.
- 098900 ADD 2 TO LINE-CNT.
- 099000 GO TO 4800-EXIT-PRT-DET.
- 099100 4600-PRNT-VR2.
- 099200 MOVE REC-TYPE-3529-VR2-S1 TO REC-TYPE-3529-VR2-P1.
- 099300 MOVE FMT-NO-3576-VR2-S1 TO FMT-NO-3576-VR2-P1.
- 099400 MOVE FMT-CD-3579-VR2-S1 TO FMT-CD-3579-VR2-P1.
- 099500 MOVE ADM-ST-0003-VR2-S1 TO ADM-ST-0003-VR2-P1.
- 099600 MOVE DATA-DT-6618-VR2-S1 TO DATA-DT-6618-VR2-P1.
- 099700 MOVE ACT-CD-7350-VR2-S1 TO ACT-CD-7350-VR2-P1.
- 099800 MOVE RNG-SITE-ID-3528-VR2-S1 TO RNG-SITE-ID-3528-VR2-P1.
- 099900 MOVE LINE-NO-3578-VR2-S1 TO LINE-NO-3578-VR2-P1.
- 100000 MOVE PLANT-CD-2646-VR2-S1(1) TO PLANT-CD1-2646-VR2-P1.
- 100100 MOVE POTN-PCT-3535-VR2-S1(1) TO POTN-PCT1-3535-VR2-P1.
- 100200 MOVE PLANT-CD-2646-VR2-S1(2) TO PLANT-CD2-2646-VR2-P1.
- 100300 MOVE POTN-PCT-3535-VR2-S1(2) TO POTN-PCT2-3535-VR2-P1.
- 100400 MOVE PLANT-CD-2646-VR2-S1(3) TO PLANT-CD3-2646-VR2-P1.
- 100500 MOVE POTN-PCT-3535-VR2-S1(3) TO POTN-PCT3-3535-VR2-P1.
- 100600 MOVE PLANT-CD-2646-VR2-S1(4) TO PLANT-CD4-2646-VR2-P1.
- 100700 MOVE POTN-PCT-3535-VR2-S1(4) TO POTN-PCT4-3535-VR2-P1.
- 100800 WRITE PRT-REC FROM HDR-10-DET-VR2 AFTER ADVANCING 2 LINES.
- 100900 ADD 2 TO LINE-CNT.
- 101000 GO TO 4800-EXIT-PRT-DET.
- 101100 4650-PRNT-VR3.
- 101200 MOVE REC-TYPE-3529-VR3-S1 TO REC-TYPE-3529-VR3-P1.
- 101300 MOVE FMT-NO-3576-VR3-S1 TO FMT-NO-3576-VR3-P1.
- 101400 MOVE FMT-CD-3579-VR3-S1 TO FMT-CD-3579-VR3-P1.
- 101500 MOVE ADM-ST-0003-VR3-S1 TO ADM-ST-0003-VR3-P1.
- 101600 MOVE DATA-DT-6618-VR3-S1 TO DATA-DT-6618-VR3-P1.
- 101700 MOVE ACT-CD-7350-VR3-S1 TO ACT-CD-7350-VR3-P1.
- 101800 MOVE RNG-SITE-ID-3528-VR3-S1 TO RNG-SITE-ID-3528-VR3-P1.
- 101900 MOVE LINE-NO-3578-VR3-S1 TO LINE-NO-3578-VR3-P1.
- 102000 MOVE SOIL-PHAS-4649-VR3-S1(1) TO SOIL-PHAS1-4649-VR3-P1.
- 102100 MOVE SOIL-NAM-4648-VR3-S1(1) TO SOIL-NAM1-4648-VR3-P1.
- 102200 MOVE SOIL-PHAS-4649-VR3-S1(2) TO SOIL-PHAS2-4649-VR3-P1.
- 102300 MOVE SOIL-NAM-4648-VR3-S1(2) TO SOIL-NAM2-4648-VR3-P1.
- 102400 WRITE PRT-REC FROM HDR-10-DET-VR3 AFTER ADVANCING 2 LINES.
- 102500 ADD 2 TO LINE-CNT.
- 102600 4800-EXIT-PRT-DET.
- 102700 EXIT.
- 102800 DUMMY-SECTION.
- 102900 4830-DUMMY.
- 103000 EXIT.
- 103100 END-OF-JOB.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES320E.
- 000300* EDIT/UPDATE OF STRATIFICATION (VB) AND
- 000400* ECOLOGICAL SITE (VR) FORMATS.
- 000500*
- 000600 AUTHOR. CORA FISCHER 037.
- 000700 INSTALLATION. BLM-DENVER.
- 000800 DATE-WRITTEN. 08/05/79.
- 000900 DATE-COMPILED.
- 001000* BUILDS VB-WORK-FILE FROM VB RECORDS, BUILDS
- 001100* VM-WORK-FILE FROM VR1D RECORDS.
- 001200 ENVIRONMENT DIVISION.
- 001300 CONFIGURATION SECTION.
- 001400 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001500 OBJECT-COMPUTER. LEVEL-66-ASCII SEQUENCE IS EBCDIC.
- 001600 INPUT-OUTPUT SECTION.
- 001700 FILE-CONTROL.
- 001800 SELECT VR-VB-OT-FILE ASSIGN TO D1
- 001900 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002000 SELECT VM-WORK-FILE ASSIGN TO U1
- 002100 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002200 SELECT VB-WORK-FILE ASSIGN TO B1
- 002300 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002400 SELECT VR-VB-IN-FILE ASSIGN TO I1
- 002500 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002600 SELECT PRINTFILE ASSIGN TO P1
- 002700 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002800 DATA DIVISION.
- 002900 SUB-SCHEMA SECTION.
- 003000 DB CODVAL2 WITHIN BLMDIC.
- 003100 FILE SECTION.
- 003200 FD VR-VB-IN-FILE
- 003300 CODE-SET IS GBCD
- 003400 LABEL RECORDS ARE STANDARD
- 003500 DATA RECORD IS VR-VB-IN-REC.
- 003600 01 VR-VB-IN-REC.
- 003700 03 REC-TYP-I1 PIC X(4).
- 003800 03 FILLER PIC X(58).
- 003900 03 RNG-ECOL-COND-CLS-I1 PIC X.
- 004000 03 FILLER PIC X(32).
- 004100 FD VB-WORK-FILE
- 004200 CODE-SET IS GBCD
- 004300 LABEL RECORDS ARE STANDARD
- 004400 DATA RECORD IS VB-WORK-REC.
- 004500 01 VB-WORK-REC PIC X(96).
- 004600 FD VM-WORK-FILE
- 004700 CODE-SET IS GBCD
- 004800 LABEL RECORDS ARE STANDARD
- 004900 DATA RECORD IS VM-WORK-REC.
- 005000 01 VM-WORK-REC.
- 005100 03 REC-TYP-U1 PIC X(4).
- 005200 03 SD-U1.
- 005300 05 ST-U1 PIC XX.
- 005400 05 DS-U1 PIC XX.
- 005500 03 DATE-U1 PIC X(6).
- 005600 03 ACT-U1 PIC X.
- 005700 03 STK-RATE-U1 PIC X.
- 005800 03 RNG-SITE-U1 PIC X(11).
- 005900 03 FILLER PIC X(57).
- 006000 FD VR-VB-OT-FILE
- 006100 CODE-SET IS GBCD
- 006200 LABEL RECORDS ARE STANDARD
- 006300 DATA RECORD IS VR-VB-OT-REC.
- 006400 01 VR-VB-OT-REC PIC X(96).
- 006500 FD PRINTFILE
- 006600 CODE-SET IS GBCD
- 006700 LABEL RECORDS ARE STANDARD
- 006800 DATA RECORD IS PRT-REC.
- 006900 01 PRT-REC PIC X(132).
- 007000 WORKING-STORAGE SECTION.
- 007100 77 I PIC 9 VALUE ZERO.
- 007200 77 VB-IN-CNT PIC 99 VALUE ZERO,
- 007300 77 RNG-SITE-HLD PIC X(11) VALUE SPACE.
- 007400 77 ERR-FREE PIC 9 VALUE 0.
- 007500 77 RNGE-SITE-SAME PIC 9 VALUE 0.
- 007600 77 SWITCH-LINE1 PIC 9 VALUE ZERO.
- 007700 77 PAGE-CTR PIC 9(6) VALUE ZERO.
- 007800 77 LINE-CTR PIC 99 VALUE ZERO.
- 007900 77 INPUT-CTR PIC 9(5) VALUE ZERO.
- 008000 77 GOOD-CTR PIC 9(5) VALUE ZERO.
- 008100 77 ERROR-CTR PIC 9(5) VALUE ZERO.
- 008200 77 DRP-ERR-CTR COMP-6 VALUE ZERO.
- 008300 77 UNKWN-LITRL PIC X(15) VALUE "UNKNOWN ".
- 008400 77 DB-ERR-PARA PIC X(4).
- 008500 77 RNG-SITE-TALLY COMP-6.
- 008600 77 PLU-HOLD PIC X(2).
- 008700 01 NAMES-HOLD.
- 008800 05 FUNC-HLD.
- 008900 10 ST-NM-HLD PIC X(10).
- 009000 10 FILLER PIC X.
- 009100 05 EXPL-HLD.
- 009200 10 DIST-NM-HLD PIC X(10).
- 009300 10 FILLER PIC X.
- 009400 10 RA-NM-HLD PIC X(12).
- 009500 10 FILLER PIC X.
- 009600 10 PU-NM-HLD PIC X(15).
- 009700 10 FILLER PIC X.
- 009800 01 REC-TYP-HLD-2.
- 009900 05 H-REC-TYP-VB1Z PIC XX.
- 010000 05 H-FMT-NUM-VB1Z PIC 9(1).
- 010100 05 H-FORMAT-CD-VB1Z PIC X(1).
- 010200 01 HLD-ST PIC XX.
- 010300 01 HLD-DIST PIC XX.
- 010400 01 HLD-RA PIC XX.
- 010500 01 HLD-PU PIC XX.
- 010600 01 HLD-CLMTC-ADJ-FCTR PIC X(5).
- 010700 01 HLD-RNG-SITE-ID PIC X(11).
- 010800 01 EOF-SWITCH PIC 9 VALUE ZERO.
- 010900 88 EOF VALUE 1.
- 011000 01 HEADING-SWITCH PIC 9 VALUE ZERO.
- 011100 88 ST-DIST-PLU-CHANGE VALUE 1.
- 011200 COPY DBSTATUS IN TPCOBOLIB.
- 011300 01 AS-OF-DATE.
- 011400 03 AS-OF-YR PIC X(02).
- 011500 03 AS-OF-MO PIC 9(02).
- 011600 03 AS-OF-DA PIC X(02).
- 011700 01 MONTH-TABLE.
- 011800 03 MO-TAB.
- 011900 05 FILLER PIC X(03) VALUE "JAN".
- 012000 05 FILLER PIC X(03) VALUE "FEB".
- 012100 05 FILLER PIC X(03) VALUE "MAR".
- 012200 05 FILLER PIC X(03) VALUE "APR".
- 012300 05 FILLER PIC X(03) VALUE "MAY".
- 012400 05 FILLER PIC X(03) VALUE "JUN".
- 012500 05 FILLER PIC X(03) VALUE "JUL".
- 012600 05 FILLER PIC X(03) VALUE "AUG".
- 012700 05 FILLER PIC X(03) VALUE "SEP".
- 012800 05 FILLER PIC X(03) VALUE "OCT".
- 012900 05 FILLER PIC X(03) VALUE "NOV".
- 013000 05 FILLER PIC X(03) VALUE "DEC".
- 013100 03 MON REDEFINES MO-TAB PIC X(03) OCCURS 12 TIMES.
- 013200 01 HDR-1.
- 013300 05 FILLER PIC X(4) VALUE SPACES.
- 013400 05 FILLER PIC X(5) VALUE
- 013500 "PCN: ".
- 013600 05 HDR-PCN PIC X(8).
- 013700 05 FILLER PIC X(7) VALUE
- 013800 " AS OF ".
- 013900 05 HDR-DD PIC XX.
- 014000 05 FILLER PIC X VALUE SPACE.
- 014100 05 HDR-MMM PIC XXX.
- 014200 05 FILLER PIC X VALUE SPACE.
- 014300 05 HDR-YR PIC XX.
- 014400 05 FILLER PIC X(09) VALUE SPACES.
- 014500 05 FILLER PIC X(48) VALUE
- 014600 "USDI- BUR OF LAND MGT ECOLOGICAL SITE INVENTORY".
- 014700 05 FILLER PIC X(29) VALUE SPACES.
- 014800 05 FILLER PIC X(7) VALUE
- 014900 "PAGE: ".
- 015000 05 HDR-PG PIC ZZZZZ9.
- 015100 01 HDR-2.
- 015200 05 FILLER PIC X(17) VALUE SPACES.
- 015300 05 FILLER PIC X(8) VALUE
- 015400 "STATE: ".
- 015500 05 HDR-ST-NM PIC X(15).
- 015600 05 FILLER PIC X(16) VALUE SPACES.
- 015700 05 FILLER PIC X(7) VALUE
- 015800 "DIST: ".
- 015900 05 HDR-DIST-NM PIC X(15).
- 016000 05 FILLER PIC X(15) VALUE SPACES.
- 016100 05 HDR-VB-EDIT PIC X(22) VALUE
- 016200 "VB EDIT ERROR LISTING".
- 016300 05 FILLER PIC X(17) VALUE SPACES.
- 016400 01 VB-HDR-REC1.
- 016500 05 FILLER PIC X(10) VALUE SPACES.
- 016600 05 FILLER PIC X(33) VALUE
- 016700 "REC-TYP ST DIST".
- 016800 05 FILLER PIC X(29) VALUE
- 016900 " RA PLU ".
- 017000 05 FILLER PIC X(36) VALUE
- 017100 " CLIMATIC ADJ DATE".
- 017200 05 FILLER PIC X(24) VALUE
- 017300 " ACTN ".
- 017400 01 VB-HDR-REC2.
- 017500 05 FILLER PIC X(12) VALUE SPACES.
- 017600 05 FILLER PIC X(31) VALUE
- 017700 "1-4 5-6 7-8".
- 017800 05 FILLER PIC X(43) VALUE
- 017900 " 9-10 11-12 ".
- 018000 05 FILLER PIC X(35) VALUE
- 018100 "13-17 18-23 24".
- 018200 05 FILLER PIC X(11) VALUE SPACES.
- 018300 01 VB-HDR-REC3.
- 018400 05 FILLER PIC X(12) VALUE SPACES.
- 018500 05 FILLER PIC X(4) VALUE "XXXX".
- 018600 05 FILLER PIC X(11) VALUE SPACES.
- 018700 05 FILLER PIC XX VALUE "XX".
- 018800 05 FILLER PIC X(11) VALUE SPACES.
- 018900 05 FILLER PIC XX VALUE "XX".
- 019000 05 FILLER PIC X(11) VALUE SPACES.
- 019100 05 FILLER PIC XX VALUE "XX".
- 019200 05 FILLER PIC X(13) VALUE SPACES.
- 019300 05 FILLER PIC XX VALUE "XX".
- 019400 05 FILLER PIC X(16) VALUE SPACES.
- 019500 05 FILLER PIC X(5) VALUE
- 019600 "XXXXX".
- 019700 05 FILLER PIC X(12) VALUE SPACES.
- 019800 05 FILLER PIC X(6) VALUE
- 019900 "XXXXXX".
- 020000 05 FILLER PIC X(11) VALUE SPACES.
- 020100 05 FILLER PIC X VALUE "X".
- 020200 05 FILLER PIC X(11) VALUE SPACES.
- 020300 01 VB-DET-LN1.
- 020400 05 FILLER PIC X(12) VALUE SPACES.
- 020500 05 REC-TYP-P PIC XXXX.
- 020600 05 FILLER PIC X(11) VALUE SPACES.
- 020700 05 ST-P PIC XX.
- 020800 05 FILLER PIC X(11) VALUE SPACES.
- 020900 05 DIST-P PIC XX.
- 021000 05 FILLER PIC X(11) VALUE SPACES.
- 021100 05 RS-P PIC XX.
- 021200 05 FILLER PIC X(13) VALUE SPACES.
- 021300 05 PU-P PIC XX.
- 021400 05 FILLER PIC X(16) VALUE SPACES.
- 021500 05 CLIMATIC-ADJ-P PIC X(5).
- 021600 05 FILLER PIC X(12) VALUE SPACES.
- 021700 05 DATE-P PIC X(6).
- 021800 05 FILLER PIC X(11) VALUE SPACES.
- 021900 05 ACTN-P PIC X.
- 022000 05 FILLER PIC X(11) VALUE SPACES.
- 022100 01 VB-ASTERISK-LN1.
- 022200 05 FILLER PIC X(12) VALUE SPACES.
- 022300 05 REC-TYP-ERR PIC XXXX.
- 022400 05 FILLER PIC X(11) VALUE SPACES.
- 022500 05 ST-ERR PIC XX.
- 022600 05 FILLER PIC X(11) VALUE SPACES.
- 022700 05 DIST-ERR PIC XX.
- 022800 05 FILLER PIC X(11) VALUE SPACES.
- 022900 05 RS-ERR PIC XX.
- 023000 05 FILLER PIC X(13) VALUE SPACES.
- 023100 05 PU-ERR PIC XX.
- 023200 05 FILLER PIC X(16) VALUE SPACES.
- 023300 05 CLIMATIC-ADJ-ERR PIC X(5).
- 023400 05 FILLER PIC X(12) VALUE SPACES.
- 023500 05 DATE-ERR PIC X(6).
- 023600 05 FILLER PIC X(11) VALUE SPACES.
- 023700 05 ACTN-ERR PIC X.
- 023800 05 FILLER PIC X(11) VALUE SPACES.
- 023900 01 VB-HDR-REC4.
- 024000 05 FILLER PIC X(5) VALUE SPACES.
- 024100 05 FILLER PIC X(40) VALUE
- 024200 "LIN NUM SWA TRNSCT % SWA RNGE SITE ".
- 024300 05 FILLER PIC X(42) VALUE
- 024400 "STRTUM ALLOT PASTURE VEG SUB COND CL ".
- 024500 05 FILLER PIC X(45) VALUE
- 024600 "% SLOPE SLOPE ASP LAND FORM SOIL PHASE ".
- 024700 01 VB-HDR-REC5.
- 024800 05 FILLER PIC X(6) VALUE SPACES.
- 024900 05 FILLER PIC X(47) VALUE
- 025000 "25-28 29-32 33-34 35-37 38-48 49-52 ".
- 025100 05 FILLER PIC X(40) VALUE
- 025200 "53-56 57-58 59-62 63 64-66".
- 025300 05 FILLER PIC X(39) VALUE
- 025400 " 67-68 69-71 72-76 ".
- 025500 01 VB-HDR-REC6.
- 025600 05 FILLER PIC X(7) VALUE SPACES.
- 025700 05 FILLER PIC X(4) VALUE "XXXX".
- 025800 05 FILLER PIC XXX VALUE SPACES.
- 025900 05 FILLER PIC X(4) VALUE "XXXX".
- 026000 05 FILLER PIC X(4) VALUE SPACES.
- 026100 05 FILLER PIC XX VALUE "XX".
- 026200 05 FILLER PIC X(4) VALUE SPACES.
- 026300 05 FILLER PIC XXX VALUE "XXX".
- 026400 05 FILLER PIC XX VALUE SPACES.
- 026500 05 FILLER PIC X(11) VALUE
- 026600 "XXXXXXXXXXX".
- 026700 05 FILLER PIC XXX VALUE SPACES.
- 026800 05 FILLER PIC XXX VALUE "XXX".
- 026900 05 FILLER PIC X(4) VALUE SPACES.
- 027000 05 FILLER PIC X(4) VALUE
- 027100 "XXXX".
- 027200 05 FILLER PIC X(5) VALUE SPACES.
- 027300 05 FILLER PIC XX VALUE "XX".
- 027400 05 FILLER PIC X(6) VALUE SPACES.
- 027500 05 FILLER PIC XXXX VALUE "XXXX".
- 027600 05 FILLER PIC X(6) VALUE SPACES.
- 027700 05 FILLER PIC X VALUE "X".
- 027800 05 FILLER PIC X(7) VALUE SPACES.
- 027900 05 FILLER PIC XXX VALUE "XXX".
- 028000 05 FILLER PIC X(8) VALUE SPACES.
- 028100 05 FILLER PIC XX VALUE "XX".
- 028200 05 FILLER PIC X(8) VALUE SPACES.
- 028300 05 FILLER PIC XXX VALUE "XXX".
- 028400 05 FILLER PIC X(8) VALUE SPACES.
- 028500 05 FILLER PIC X(5) VALUE
- 028600 "XXXXX".
- 028700 05 FILLER PIC X(6) VALUE SPACES.
- 028800 01 VB-DET-LN2.
- 028900 05 FILLER PIC X(7) VALUE SPACES.
- 029000 05 VB-LIN-NUM-P PIC XXXX.
- 029100 05 FILLER PIC XX VALUE SPACES.
- 029200 05 VB-SWA-P PIC XXXX.
- 029300 05 FILLER PIC X(4) VALUE SPACES.
- 029400 05 VB-TRN-P PIC XX.
- 029500 05 FILLER PIC X(4) VALUE SPACES.
- 029600 05 VB-PCT-SWA-P PIC XXX.
- 029700 05 FILLER PIC XX VALUE SPACES.
- 029800 05 VB-RNGE-SITE-P PIC X(11).
- 029900 05 FILLER PIC XX VALUE SPACES.
- 030000 05 VB-STRTUM-P PIC XXXX.
- 030100 05 FILLER PIC X(4) VALUE SPACES.
- 030200 05 VB-ALLOT-P PIC XXXX.
- 030300 05 FILLER PIC X(5) VALUE SPACES.
- 030400 05 VB-PASTURE-P PIC XX.
- 030500 05 FILLER PIC X(6) VALUE SPACES.
- 030600 05 VB-VEG-SUB-P PIC XXXX.
- 030700 05 FILLER PIC X(6) VALUE SPACES.
- 030800 05 VB-COND-CL-P PIC X.
- 030900 05 FILLER PIC X(7) VALUE SPACES.
- 031000 05 VB-PCT-SLOPE-P PIC XXX.
- 031100 05 FILLER PIC X(8) VALUE SPACES.
- 031200 05 VB-SLOPE-ASP-P PIC XX.
- 031300 05 FILLER PIC X(8) VALUE SPACES.
- 031400 05 VB-LAND-FORM-P PIC XXX.
- 031500 05 FILLER PIC X(8) VALUE SPACES.
- 031600 05 VB-SOIL-PHASE-P PIC X(5).
- 031700 05 FILLER PIC X(6) VALUE SPACES.
- 031800 01 VB-ASTERISK-LN2.
- 031900 05 FILLER PIC X(7) VALUE SPACES.
- 032000 05 VB-LIN-NUM-ERR PIC XXXX.
- 032100 05 FILLER PIC XX VALUE SPACES.
- 032200 05 VB-SWA-ERR PIC XXXX.
- 032300 05 FILLER PIC X(4) VALUE SPACES.
- 032400 05 VB-TRNSCT-ERR PIC XX.
- 032500 05 FILLER PIC X(4) VALUE SPACES.
- 032600 05 VB-PCT-SWA-ERR PIC XXX.
- 032700 05 FILLER PIC XX VALUE SPACES.
- 032800 05 VB-RNGE-SITE-ERR PIC X(11).
- 032900 05 VB-RNGE-SITE-ERR-RE REDEFINES VB-RNGE-SITE-ERR.
- 033000 10 VB-RNGSITE-ERR-4 PIC XXXX.
- 033100 10 VB-RNGSITE-ERR-3 PIC XXX.
- 033200 10 VB-RNGSITE-ERR-ALL PIC XXXX.
- 033300 05 FILLER PIC XXX VALUE SPACES.
- 033400 05 VB-STRTUM-ERR PIC XXX.
- 033500 05 FILLER PIC X(4) VALUE SPACES.
- 033600 05 VB-ALLOT-ERR PIC XXXX.
- 033700 05 FILLER PIC X(5) VALUE SPACES.
- 033800 05 VB-PASTURE-ERR PIC XX.
- 033900 05 FILLER PIC X(6) VALUE SPACES.
- 034000 05 VB-VEG-SUB-ERR PIC XXXX.
- 034100 05 FILLER PIC X(6) VALUE SPACES.
- 034200 05 VB-COND-CL-ERR PIC X.
- 034300 05 FILLER PIC X(7) VALUE SPACES.
- 034400 05 VB-PCT-SLOPE-ERR PIC XXX.
- 034500 05 FILLER PIC X(8) VALUE SPACES.
- 034600 05 VB-SLOPE-ASP-ERR PIC XX.
- 034700 05 FILLER PIC X(8).
- 034800 05 VB-LAND-FORM-ERR PIC XXX.
- 034900 05 FILLER PIC X(8) VALUE SPACES.
- 035000 05 VB-SOIL-PHASE-ERR PIC X(5).
- 035100 05 FILLER PIC X(6) VALUE SPACES.
- 035200 01 VR-HDR-ST.
- 035300 05 FILLER PIC X(17) VALUE SPACES.
- 035400 05 FILLER PIC X(8) VALUE
- 035500 "STATE: ".
- 035600 05 HDR-VR-ST PIC X(15).
- 035700 05 FILLER PIC X(53) VALUE SPACES.
- 035800 05 HDR-VR-TIT PIC X(22).
- 035900 05 FILLER PIC X(17) VALUE SPACES.
- 036000 01 VR-HDR-REC1.
- 036100 05 FILLER PIC X(10) VALUE SPACES.
- 036200 05 FILLER PIC X(47) VALUE
- 036300 "REC-TYP ST DATE ACTN".
- 036400 05 FILLER PIC X(19) VALUE
- 036500 " RANGE SITE NO".
- 036600 05 FILLER PIC X(56) VALUE SPACES.
- 036700 01 VR-HDR-REC2.
- 036800 05 FILLER PIC X(12) VALUE SPACES.
- 036900 05 FILLER PIC X(4) VALUE "1-4".
- 037000 05 FILLER PIC X(11) VALUE SPACES.
- 037100 05 FILLER PIC X(3) VALUE "5-6".
- 037200 05 FILLER PIC X(9) VALUE SPACES.
- 037300 05 FILLER PIC X(5) VALUE
- 037400 "13-18".
- 037500 05 FILLER PIC X(11) VALUE SPACES.
- 037600 05 FILLER PIC XX VALUE "19".
- 037700 05 FILLER PIC X(11) VALUE SPACES.
- 037800 05 FILLER PIC X(5) VALUE "20-30".
- 037900 05 FILLER PIC X(60) VALUE SPACES.
- 038000 01 VR-HDR-REC3.
- 038100 05 FILLER PIC X(12) VALUE SPACE.
- 038200 05 FILLER PIC XXXX VALUE "XXXX".
- 038300 05 FILLER PIC X(11) VALUE SPACES.
- 038400 05 FILLER PIC XX VALUE "XX".
- 038500 05 FILLER PIC X(9) VALUE SPACES.
- 038600 05 FILLER PIC X(6) VALUE
- 038700 "XXXXXX".
- 038800 05 FILLER PIC X(11) VALUE SPACES.
- 038900 05 FILLER PIC X VALUE "X".
- 039000 05 FILLER PIC X(8) VALUE SPACES.
- 039100 05 FILLER PIC X(11) VALUE
- 039200 "XXXXXXXXXXX".
- 039300 05 FILLER PIC X(56) VALUE SPACES.
- 039400 01 VR-HDR-DET-LN1.
- 039500 05 FILLER PIC X(12) VALUE SPACES.
- 039600 05 HDR-VR-REC-TYP-P PIC XXXX.
- 039700 05 FILLER PIC X(11) VALUE SPACES.
- 039800 05 HDR-VR-ST-P PIC XX.
- 039900 05 FILLER PIC X(9) VALUE SPACES.
- 040000 05 HDR-VR-DATE-P PIC X(6).
- 040100 05 FILLER PIC X(11) VALUE SPACES.
- 040200 05 HDR-VR-ACTN-P PIC X.
- 040300 05 FILLER PIC X(8) VALUE SPACES.
- 040400 05 HDR-VR-RNG-SITE-NO-P PIC X(11).
- 040500 05 FILLER PIC X(57) VALUE SPACES.
- 040600 01 VR-HDR-ASTERISK-LN1.
- 040700 05 FILLER PIC X(12) VALUE SPACES.
- 040800 05 HDR-VR-REC-TYP-ERR PIC XXXX.
- 040900 05 FILLER PIC X(11) VALUE SPACES.
- 041000 05 HDR-VR-ST-ERR PIC XX.
- 041100 05 FILLER PIC X(9) VALUE SPACES.
- 041200 05 HDR-VR-DATE-ERR PIC X(6).
- 041300 05 FILLER PIC X(11) VALUE SPACES.
- 041400 05 HDR-VR-ACTN-ERR PIC X.
- 041500 05 FILLER PIC X(8) VALUE SPACES.
- 041600 05 HDR-VR-RNG-SITE-NO-ERR PIC X(11).
- 041700 05 VR-RNG-SITE-ERR REDEFINES HDR-VR-RNG-SITE-NO-ERR.
- 041800 10 VR-RNGSITE-ERR-4 PIC XXXX.
- 041900 10 VR-RNGSITE-ERR-3 PIC XXX.
- 042000 10 VR-RNGSITE-ALL-ERR PIC XXXX.
- 042100 05 FILLER PIC X(57) VALUE SPACES.
- 042200 01 VR1-HDR-REC1.
- 042300 05 FILLER PIC X(5) VALUE SPACES.
- 042400 05 FILLER PIC X(29) VALUE
- 042500 "LIN NUM RNGE SITE NAME".
- 042600 05 FILLER PIC X(44) VALUE
- 042700 " PRECIP SOIL SURFACE AVG YR".
- 042800 05 FILLER PIC X(41) VALUE
- 042900 " FAVORABLE YR UNFAVORABLE YR ".
- 043000 05 FILLER PIC X(13) VALUE SPACES.
- 043100 01 VR1-HDR-REC2.
- 043200 05 FILLER PIC X(6) VALUE SPACES.
- 043300 05 FILLER PIC X(24) VALUE
- 043400 "31-34 35-42".
- 043500 05 FILLER PIC X(11) VALUE SPACES.
- 043600 05 FILLER PIC X(37) VALUE
- 043700 "43-46 47-49 50-55".
- 043800 05 FILLER PIC X(16) VALUE
- 043900 " 56-61".
- 044000 05 FILLER PIC X(15) VALUE SPACES.
- 044100 05 FILLER PIC X(10) VALUE
- 044200 "62-67 ".
- 044300 05 FILLER PIC X(13) VALUE SPACES.
- 044400 01 VR1-HDR-REC3.
- 044500 05 FILLER PIC X(7) VALUE SPACES.
- 044600 05 FILLER PIC XXXX VALUE "XXXX".
- 044700 05 FILLER PIC X(5) VALUE SPACES.
- 044800 05 FILLER PIC X(7) VALUE SPACES.
- 044900 05 FILLER PIC X(8) VALUE
- 045000 "XXXXXXXX".
- 045100 05 FILLER PIC X(10) VALUE SPACES.
- 045200 05 FILLER PIC XXXX VALUE "XXXX".
- 045300 05 FILLER PIC X(12) VALUE SPACES.
- 045400 05 FILLER PIC XXX VALUE "XXX".
- 045500 05 FILLER PIC X(12) VALUE SPACES.
- 045600 05 FILLER PIC X(7) VALUE
- 045700 "XXXXXXX".
- 045800 05 FILLER PIC X(10) VALUE SPACES.
- 045900 05 FILLER PIC X(6) VALUE
- 046000 "XXXXXX".
- 046100 05 FILLER PIC X(14) VALUE SPACES.
- 046200 05 FILLER PIC X(6) VALUE
- 046300 "XXXXXX".
- 046400 05 FILLER PIC X(4) VALUE SPACES.
- 046500 05 FILLER PIC X(13) VALUE SPACES.
- 046600 01 VR1-HDR-DET-LN2.
- 046700 05 FILLER PIC X(7) VALUE SPACES.
- 046800 05 VR1-LIN-NUM-P PIC XXXX.
- 046900 05 FILLER PIC X(12) VALUE SPACES.
- 047000 05 VR1-RNGSITE-NM-P PIC X(8).
- 047100 05 FILLER PIC X(10) VALUE SPACES.
- 047200 05 VR1-PRECIP-P PIC XXXX.
- 047300 05 FILLER PIC X(12) VALUE SPACES.
- 047400 05 VR1-SOIL-SURF-P PIC XXX.
- 047500 05 FILLER PIC X(12) VALUE SPACES.
- 047600 05 VR1-AVG-YR-P PIC X(6).
- 047700 05 FILLER PIC X(11) VALUE SPACES.
- 047800 05 VR1-FAVORABLE-YR-P PIC X(6).
- 047900 05 FILLER PIC X(14) VALUE SPACES.
- 048000 05 VR1-UNFAVORABLE-YR-P PIC X(6).
- 048100 05 FILLER PIC X(17) VALUE SPACES.
- 048200 01 VR1-HDR-ASTERISK-LN2.
- 048300 05 FILLER PIC X(7) VALUE SPACES.
- 048400 05 VR1-LIN-NUM-ERR PIC XXXX.
- 048500 05 FILLER PIC X(12) VALUE SPACES.
- 048600 05 VR1-RNGSITE-NM-ERR PIC X(8).
- 048700 05 FILLER PIC X(10) VALUE SPACES.
- 048800 05 VR1-PRECIP-ERR PIC XXXX.
- 048900 05 FILLER PIC X(12).
- 049000 05 VR1-SOIL-SURF-ERR PIC XXX.
- 049100 05 FILLER PIC X(12) VALUE SPACES.
- 049200 05 VR1-AVG-YR-ERR PIC X(6).
- 049300 05 FILLER PIC X(11) VALUE SPACES.
- 049400 05 VR1-FAVORABLE-YR-ERR PIC X(6).
- 049500 05 FILLER PIC X(14) VALUE SPACES.
- 049600 05 VR1-UNFAVORABLE-YR-ERR PIC X(6).
- 049700 05 FILLER PIC X(17) VALUE SPACES.
- 049800 01 VR2-HDR-REC1.
- 049900 05 FILLER PIC X(6) VALUE SPACES.
- 050000 05 FILLER PIC X(49) VALUE
- 050100 "LIN NUM PLANT CD COMP PCT PLANT CD".
- 050200 05 FILLER PIC X(21) VALUE
- 050300 " COMP PCT ".
- 050400 05 FILLER PIC X(57) VALUE
- 050500 "PLANT CD COMP PCT PLANT CD COMP-PCT ".
- 050600 01 VR2-HDR-REC2.
- 050700 05 FILLER PIC X(7) VALUE SPACES.
- 050800 05 FILLER PIC X(33) VALUE
- 050900 "31-34 35-41 42-44".
- 051000 05 FILLER PIC X(42) VALUE
- 051100 " 45-51 52-54 55-61".
- 051200 05 FILLER PIC X(42) VALUE
- 051300 " 62-64 65-71 72-74".
- 051400 05 FILLER PIC X(8) VALUE SPACES.
- 051500 01 VR2-HDR-REC3.
- 051600 05 FILLER PIC X(8) VALUE SPACES.
- 051700 05 FILLER PIC XXXX VALUE "XXXX".
- 051800 05 FILLER PIC X(8) VALUE SPACES.
- 051900 05 FILLER PIC X(7) VALUE
- 052000 "XXXXXXX".
- 052100 05 FILLER PIC X(9) VALUE SPACES.
- 052200 05 FILLER PIC XXX VALUE "XXX".
- 052300 05 FILLER PIC X(9) VALUE SPACES.
- 052400 05 FILLER PIC X(7) VALUE
- 052500 "XXXXXXX".
- 052600 05 FILLER PIC X(9) VALUE SPACES.
- 052700 05 FILLER PIC XXX VALUE "XXX".
- 052800 05 FILLER PIC X(9) VALUE SPACES.
- 052900 05 FILLER PIC X(7) VALUE
- 053000 "XXXXXXX".
- 053100 05 FILLER PIC X(9) VALUE SPACES.
- 053200 05 FILLER PIC XXX VALUE "XXX".
- 053300 05 FILLER PIC X(9) VALUE SPACES.
- 053400 05 FILLER PIC X(7) VALUE
- 053500 "XXXXXXX".
- 053600 05 FILLER PIC X(9) VALUE SPACES.
- 053700 05 FILLER PIC XXX VALUE "XXX".
- 053800 05 FILLER PIC X(9) VALUE SPACES.
- 053900 01 VR2-HDR-DET-LN2.
- 054000 05 FILLER PIC X(8) VALUE SPACES.
- 054100 05 VR2-LIN-NUM-P PIC XXXX.
- 054200 05 FILLER PIC X(8) VALUE SPACES.
- 054300 05 VR2-PLANT-CD1-P PIC X(7).
- 054400 05 FILLER PIC X(9) VALUE SPACES.
- 054500 05 VR2-COMP-PCT1-P PIC XXX.
- 054600 05 FILLER PIC X(9) VALUE SPACES.
- 054700 05 VR2-PLANT-CD2-P PIC X(7).
- 054800 05 FILLER PIC X(9) VALUE SPACES.
- 054900 05 VR2-COMP-PCT2-P PIC XXX.
- 055000 05 FILLER PIC X(9) VALUE SPACES.
- 055100 05 VR2-PLANT-CD3-P PIC X(7).
- 055200 05 FILLER PIC X(9) VALUE SPACES.
- 055300 05 VR2-COMP-PCT3-P PIC XXX.
- 055400 05 FILLER PIC X(9) VALUE SPACES.
- 055500 05 VR2-PLANT-CD4-P PIC X(7).
- 055600 05 FILLER PIC X(9) VALUE SPACES.
- 055700 05 VR2-COMP-PCT4-P PIC XXX.
- 055800 05 FILLER PIC X(9) VALUE SPACES.
- 055900 01 VR2-HDR-ASTERISK-LN2.
- 056000 05 FILLER PIC X(8) VALUE SPACES.
- 056100 05 VR2-LIN-NUM-ERR PIC XXXX.
- 056200 05 FILLER PIC X(8) VALUE SPACES.
- 056300 05 VR2-PLANT-CD1-ERR PIC X(7).
- 056400 05 FILLER PIC X(9) VALUE SPACES.
- 056500 05 VR2-COMP-PCT1-ERR PIC XXX.
- 056600 05 FILLER PIC X(9) VALUE SPACES.
- 056700 05 VR2-PLANT-CD2-ERR PIC X(7).
- 056800 05 FILLER PIC X(9) VALUE SPACES.
- 056900 05 VR2-COMP-PCT2-ERR PIC XXX.
- 057000 05 FILLER PIC X(9) VALUE SPACES.
- 057100 05 VR2-PLANT-CD3-ERR PIC X(7).
- 057200 05 FILLER PIC X(9) VALUE SPACES.
- 057300 05 VR2-COMP-PCT3-ERR PIC XXX.
- 057400 05 FILLER PIC X(9) VALUE SPACES.
- 057500 05 VR2-PLANT-CD4-ERR PIC X(7).
- 057600 05 FILLER PIC X(9) VALUE SPACES.
- 057700 05 VR2-COMP-PCT4-ERR PIC XXX.
- 057800 05 FILLER PIC X(9) VALUE SPACES.
- 057900 01 VR3-HDR-REC1.
- 058000 05 FILLER PIC X(6) VALUE SPACES.
- 058100 05 FILLER PIC X(39) VALUE
- 058200 "LIN NUM SOIL PHASE ".
- 058300 05 FILLER PIC X(24) VALUE
- 058400 "SOIL NAME ".
- 058500 05 FILLER PIC X(25) VALUE
- 058600 "SOIL PHASE ".
- 058700 05 FILLER PIC X(9) VALUE
- 058800 "SOIL NAME".
- 058900 05 FILLER PIC X(29) VALUE SPACES.
- 059000 01 VR3-HDR-REC2.
- 059100 05 FILLER PIC X(7) VALUE SPACES.
- 059200 05 FILLER PIC X(20) VALUE
- 059300 "31-34 35-39".
- 059400 05 FILLER PIC X(20) VALUE SPACES.
- 059500 05 FILLER PIC X(5) VALUE
- 059600 "40-63".
- 059700 05 FILLER PIC X(20) VALUE SPACES.
- 059800 05 FILLER PIC X(5) VALUE
- 059900 "64-68".
- 060000 05 FILLER PIC X(19) VALUE SPACES.
- 060100 05 FILLER PIC X(5) VALUE
- 060200 "69-92".
- 060300 05 FILLER PIC X(31) VALUE SPACES.
- 060400 01 VR3-HDR-REC3.
- 060500 05 FILLER PIC X(8) VALUE SPACES.
- 060600 05 FILLER PIC XXXX VALUE "XXXX".
- 060700 05 FILLER PIC X(10) VALUE SPACES.
- 060800 05 FILLER PIC X(5) VALUE
- 060900 "XXXXX".
- 061000 05 FILLER PIC X(12) VALUE SPACES.
- 061100 05 FILLER PIC X(24) VALUE
- 061200 "XXXXXXXXXXXXXXXXXXXXXXXX".
- 061300 05 FILLER PIC X(11) VALUE SPACES.
- 061400 05 FILLER PIC X(5) VALUE
- 061500 "XXXXX".
- 061600 05 FILLER PIC X(9) VALUE SPACES.
- 061700 05 FILLER PIC X(24) VALUE
- 061800 "XXXXXXXXXXXXXXXXXXXXXXXX".
- 061900 05 FILLER PIC X(22) VALUE SPACES.
- 062000 01 VR3-HDR-DET-LN2.
- 062100 05 FILLER PIC X(8) VALUE SPACES.
- 062200 05 VR3-LIN-NUM-P PIC XXXX.
- 062300 05 FILLER PIC X(10) VALUE SPACES.
- 062400 05 VR3-SOIL-PHASE1-P PIC X(5).
- 062500 05 FILLER PIC X(10) VALUE SPACES.
- 062600 05 VR3-SOIL-NM1-P PIC X(24).
- 062700 05 FILLER PIC X(11) VALUE SPACES.
- 062800 05 VR3-SOIL-PHASE2-P PIC X(5).
- 062900 05 FILLER PIC X(9) VALUE SPACES.
- 063000 05 VR3-SOIL-NM2-P PIC X(24).
- 063100 05 FILLER PIC X(22) VALUE SPACES.
- 063200 01 VR3-HDR-ASTERISK-LN2.
- 063300 05 FILLER PIC X(8) VALUE SPACES.
- 063400 05 VR3-LIN-NUM-ERR PIC X(4).
- 063500 05 FILLER PIC X(10) VALUE SPACES.
- 063600 05 VR3-SOIL-PHASE1-ERR PIC X(5).
- 063700 05 FILLER PIC X(10) VALUE SPACES.
- 063800 05 VR3-SOIL-NM1-ERR PIC X(24).
- 063900 05 FILLER PIC X(11) VALUE SPACES.
- 064000 05 VR3-SOIL-PHASE2-ERR PIC X(5).
- 064100 05 FILLER PIC X(9) VALUE SPACES.
- 064200 05 VR3-SOIL-NM2-ERR PIC X(24).
- 064300 05 FILLER PIC X(22) VALUE SPACES.
- 064400 01 VR-VB-REC-HLD.
- 064500 05 REC-TYP-HLD.
- 064600 10 REC-TYP-VB1Z PIC XX.
- 064700 10 FMT-NUM-VB1Z PIC X(1).
- 064800 10 FORMAT-CD-VB1Z PIC X(1).
- 064900 05 BLM-ADM-U-VB1Z.
- 065000 07 SDR-VB1Z.
- 065100 08 SD-VB1Z.
- 065200 09 ADST-CD-VB1Z PIC XX.
- 065300 09 DIST-CD-VB1Z PIC XX.
- 065400 08 RA-CD-VB1Z PIC XX.
- 065500 07 PU-CD-VB1Z PIC XX.
- 065600 05 CLMTC-ADJ-FCTR-VB1Z PIC X(5).
- 065700 05 DATA-DATE-VB1Z PIC X(6).
- 065800 05 ACTION-CD-VB1Z PIC X(1).
- 065900 05 LIN-NUM-VB1Z PIC X(4).
- 066000 05 SWA-VB1Z.
- 066100 10 SWA-CD-VB1Z PIC X.
- 066200 10 SWA-NUM-VB1Z PIC X(3).
- 066300 05 TRN-NUM-VB1Z PIC X(2).
- 066400 05 SWA-PCT-VB1Z PIC X(3).
- 066500 05 RNG-SITE-ID-VB1Z PIC X(11).
- 066600 05 RNG-SITE-ID-VB1Z-RE REDEFINES RNG-SITE-ID-VB1Z.
- 066700 10 RNG-SITE-ID-4-VB1Z PIC XXXX.
- 066800 10 RNG-SITE-ID-3-VB1Z PIC XXX.
- 066900 10 RNG-SITE-ID-ALL-VB1Z PIC XXXX.
- 067000 05 STRATUM-NUMER-VB1Z PIC X(4).
- 067100 05 ALLOT-NUM-VB1Z PIC X(4).
- 067200 05 PASTURE-NUM-VB1Z PIC X(2).
- 067300 05 VEG-SUB-TYP-VB1Z PIC X(4).
- 067400 05 RNG-ECOL-COND-CLS-VB1Z PIC X(1).
- 067500 05 PCT-SLP-VB1Z PIC X(3).
- 067600 05 ASPT-VB1Z PIC X(2).
- 067700 05 L-FORM-VB1Z PIC X(3).
- 067800 05 SOIL-PHAS-VB1Z PIC X(5).
- 067900 05 FILLER PIC X(19).
- 068000 01 VR1-REC-HLD REDEFINES VR-VB-REC-HLD.
- 068100 05 GRP1-VR1Z.
- 068200 10 REC-TYP-VR1Z PIC X(2).
- 068300 10 FMT-NUM-VR1Z PIC X(1).
- 068400 10 FORMAT-CD-VR1Z PIC X(1).
- 068500 05 BLM-ADM-U-VR1Z.
- 068600 10 ADST-CD-VR1Z PIC XX.
- 068700 10 DIST-CD-VR1Z PIC XX.
- 068800 10 RA-CD-VR1Z PIC XX.
- 068900 10 PU-CD-VR1Z PIC XX.
- 069000 05 DATA-DATE-VR1Z PIC X(6).
- 069100 05 ACTION-CD-VR1Z PIC X(1).
- 069200 05 RNG-SITE-ID-VR1Z PIC X(11).
- 069300 05 RNG-SITE-ID-VR1Z-RE REDEFINES RNG-SITE-ID-VR1Z.
- 069400 10 RNG-SITE-ID-4-VR1Z PIC XXXX.
- 069500 10 RNG-SITE-ID-3-VR1Z PIC XXX.
- 069600 10 RNG-SITE-ID-ALL-VR1Z PIC XXXX.
- 069700 05 LIN-NUM-VR1Z PIC X(4).
- 069800 05 RNG-SITE-NAM-VR1Z PIC X(8).
- 069900 05 PRECIP-ZONE-VR1Z PIC X(4).
- 070000 05 SSF-VAL-AVG-VR1Z PIC X(3).
- 070100 05 POTN-PPA-RS-VR1Z PIC X(6) OCCURS 3 TIMES.
- 070200 05 FILLER PIC X(29).
- 070300 01 VR2-REC-HLD REDEFINES VR-VB-REC-HLD.
- 070400 05 GRP1-VR2Z.
- 070500 10 REC-TYP-VR2Z PIC X(2).
- 070600 10 FMT-NUM-VR2Z PIC X(1).
- 070700 10 FORMAT-CD-VR2Z PIC X(1).
- 070800 05 BLM-ADM-U-VR2Z.
- 070900 10 ADST-CD-VR2Z PIC XX.
- 071000 10 DIST-CD-VR2Z PIC XX.
- 071100 10 RA-CD-VR2Z PIC XX.
- 071200 10 PU-CD-VR2Z PIC XX.
- 071300 05 DATA-DATE-VR2Z PIC X(6).
- 071400 05 ACTION-CD-VR2Z PIC X(1).
- 071500 05 RNG-SITE-ID-VR2Z PIC X(11).
- 071600 05 RNG-SITE-ID-VR2Z-RE REDEFINES RNG-SITE-ID-VR2Z.
- 071700 10 RNG-SITE-ID-4-VR2Z PIC XXXX.
- 071800 10 RNG-SITE-ID-3-VR2Z PIC XXX.
- 071900 10 RNG-SITE-ID-ALL-VR2Z PIC XXXX.
- 072000 05 LIN-NUM-VR2Z PIC X(4).
- 072100 05 GRP2-VR2Z OCCURS 4 TIMES.
- 072200 10 PLANT-CD-VR2Z PIC X(7).
- 072300 10 PCT-COMP-VR2Z PIC XXX.
- 072400 05 PLANT-TYP-VR2Z PIC X OCCURS 4 TIMES.
- 072500 05 FILLER PIC X(18).
- 072600 01 VR3-REC-HLD REDEFINES VR-VB-REC-HLD.
- 072700 05 GRP1-VR3Z.
- 072800 10 REC-TYP-VR3Z PIC X(2).
- 072900 10 FMT-NUM-VR3Z PIC X(1).
- 073000 10 FORMAT-CD-VR3Z PIC X(1).
- 073100 05 BLM-ADM-U-VR3Z.
- 073200 10 ADST-CD-VR3Z PIC XX.
- 073300 10 DIST-CD-VR3Z PIC XX.
- 073400 10 RA-CD-VR3Z PIC XX.
- 073500 10 PU-CD-VR3Z PIC XX.
- 073600 05 DATA-DATE-VR3Z PIC X(6).
- 073700 05 ACTION-CD-VR3Z PIC X(1).
- 073800 05 RNG-SITE-ID-VR3Z PIC X(11).
- 073900 05 RNG-SITE-ID-VR3Z-RE REDEFINES RNG-SITE-ID-VR3Z.
- 074000 10 RNG-SITE-ID-4-VR3Z PIC XXXX.
- 074100 10 RNG-SITE-ID-3-VR3Z PIC XXX.
- 074200 10 RNG-SITE-ID-ALL-VR3Z PIC XXXX.
- 074300 05 LIN-NUM-VR3Z PIC X(4).
- 074400 05 GRP2-VR3Z OCCURS 2 TIMES.
- 074500 10 SOIL-PHAS-VR3Z PIC X(5).
- 074600 10 SOIL-NAM-VR3Z PIC X(24).
- 074700 05 FILLER PIC X(4).
- 074800 01 VB-INST-ERR-LN1.
- 074900 05 FILLER PIC X(24) VALUE SPACES.
- 075000 05 FILLER PIC X(46) VALUE
- 075100 "IF ERROR CORRECTION IS IN COMMON DATA (1-17), ".
- 075200 05 FILLER PIC X(38) VALUE
- 075300 "KEY ALL RECORDS WITH SAME COMMON DATA.".
- 075400 05 FILLER PIC X(24) VALUE SPACES.
- 075500 01 VB-INST-ERR-LN2.
- 075600 05 FILLER PIC X(24) VALUE SPACES.
- 075700 05 FILLER PIC X(51) VALUE
- 075800 "IF ERROR CORRECTION IS IN FIELD POSITIONS (29-76), ".
- 075900 05 FILLER PIC X(36) VALUE
- 076000 "KEY (1-28) AND RED CORRECTED FIELDS.".
- 076100 05 FILLER PIC X(21) VALUE SPACES.
- 076200 01 VR-INST-ERR-LN1.
- 076300 05 FILLER PIC X(24) VALUE SPACES.
- 076400 05 FILLER PIC X(62) VALUE
- 076500 "IF ERROR CORRECTION IS IN COMMON DATA (1-6 OR 20-30), KEY AL
- 076600- "L ".
- 076700 05 FILLER PIC X(30) VALUE
- 076800 "RECORDS WITH SAME COMMON DATA.".
- 076900 05 FILLER PIC X(16) VALUE SPACES.
- 077000 01 VR-INST-ERR-LN2.
- 077100 05 FILLER PIC X(24) VALUE SPACES.
- 077200 05 FILLER PIC X(51) VALUE
- 077300 "IF ERROR CORRECTION IS IN FIELD POSITIONS (35-92), ".
- 077400 05 FILLER PIC X(36) VALUE
- 077500 "KEY (1-30) AND RED CORRECTED FIELDS.".
- 077600 05 FILLER PIC X(21) VALUE SPACES.
- 077700 01 DICTIONARY-SEPARATE.
- 077800 05 DIC-NAM PIC X(23).
- 077900 05 PLANT-TYP PIC X.
- 078000 01 RANGE-SITE-ID.
- 078100 05 MLRA PIC X(3).
- 078200 05 RNG-NUM PIC X(8).
- 078300 05 RNG-CHAR REDEFINES RNG-NUM OCCURS 8 TIMES PIC X.
- 078400 01 PRT-RESULT-TOT.
- 078500 05 NO-ERRORS-P PIC X(35) VALUE SPACES.
- 078600 05 FILLER PIC X(97) VALUE SPACES.
- 078700 01 PRT-RESULT-ERROR.
- 078800 05 FILLER PIC X(7) VALUE
- 078900 "INPUT ".
- 079000 05 INPUT-CTR-P PIC 9(5).
- 079100 05 FILLER PIC X(6) VALUE
- 079200 "GOOD ".
- 079300 05 GOOD-CNTR-P PIC 9(5).
- 079400 05 FILLER PIC X(5) VALUE
- 079500 "BAD ".
- 079600 05 BAD-CNTR-P PIC 9(5).
- 079700 05 FILLER PIC X(99) VALUE SPACES.
- 079800 PROCEDURE DIVISION.
- 079900 050-CONTROL SECTION.
- 080000 100-CONTROL.
- 080100 OPEN INPUT VR-VB-IN-FILE
- 080200 OUTPUT VR-VB-OT-FILE
- 080300 OUTPUT VM-WORK-FILE, VB-WORK-FILE
- 080400 OUTPUT PRINTFILE.
- 080500 READY DIC-DE.
- 080600 MOVE 0 TO SWITCH-LINE1.
- 080700 MOVE 0 TO ERR-FREE RNGE-SITE-SAME.
- 080800 MOVE SPACES TO VR-VB-REC-HLD, VR1-REC-HLD,
- 080900 VR2-REC-HLD, VR3-REC-HLD,
- 081000 VR-VB-OT-REC.
- 081100 MOVE SPACES TO VB-ASTERISK-LN1 VB-ASTERISK-LN2
- 081200 VR-HDR-ASTERISK-LN1 VR1-HDR-ASTERISK-LN2
- 081300 VR2-HDR-ASTERISK-LN2 VR3-HDR-ASTERISK-LN2.
- 081400 READ VR-VB-IN-FILE
- 081500 AT END
- 081600 MOVE 1 TO EOF-SWITCH.
- 081700 IF (REC-TYP-I1 = "VB1D") AND
- 081800 (EOF-SWITCH = ZERO) AND
- 081900 (RNG-ECOL-COND-CLS-I1 = " ")
- 082000 MOVE "U" TO RNG-ECOL-COND-CLS-I1.
- 082100 IF EOF-SWITCH = 0
- 082200 MOVE VR-VB-IN-REC TO VR-VB-REC-HLD.
- 082300 MOVE "ES320E" TO HDR-PCN.
- 082400 ACCEPT AS-OF-DATE FROM DATE. MOVE AS-OF-DA TO HDR-DD.
- 082500 MOVE MON (AS-OF-MO) TO HDR-MMM. MOVE AS-OF-YR TO HDR-YR.
- 082600 IF (REC-TYP-I1 = "VB1D") AND
- 082700 (EOF-SWITCH = ZERO)
- 082800 MOVE VR-VB-IN-REC TO VB-WORK-REC
- 082900 WRITE VB-WORK-REC.
- 083000 IF REC-TYP-HLD = "VB1D"
- 083100 MOVE REC-TYP-HLD TO REC-TYP-HLD-2
- 083200 MOVE ADST-CD-VB1Z TO HLD-ST
- 083300 MOVE DIST-CD-VB1Z TO HLD-DIST
- 083400 MOVE RA-CD-VB1Z TO HLD-RA
- 083500 MOVE PU-CD-VB1Z TO HLD-PU
- 083600 MOVE CLMTC-ADJ-FCTR-VB1Z TO HLD-CLMTC-ADJ-FCTR
- 083700 PERFORM 435-VALIDATE-ST THRU 490-EXIT
- 083800 GO TO 130-CONT-PROCESS.
- 083900 IF REC-TYP-HLD = "VR1D" OR "VR2D" OR "VR3D"
- 084000 MOVE ADST-CD-VB1Z TO HLD-ST
- 084100 MOVE REC-TYP-HLD TO REC-TYP-HLD-2
- 084200 MOVE RNG-SITE-ID-VR2Z TO HLD-RNG-SITE-ID
- 084300 PERFORM 432-VALIDATE-ST-VR THRU 434-EXIT
- 084400 PERFORM 620A-CHK-RNGSITE THRU 621A-EXIT
- 084500 PERFORM 415-CHK-TIT.
- 084600 IF (REC-TYP-I1 = "VR1D") AND
- 084700 (EOF-SWITCH = ZERO)
- 084800 MOVE SPACE TO VM-WORK-REC
- 084900 MOVE "VM1D" TO REC-TYP-U1
- 085000 MOVE ADST-CD-VR1Z TO ST-U1
- 085100 MOVE DIST-CD-VR1Z TO DS-U1
- 085200 MOVE DATA-DATE-VR1Z TO DATE-U1
- 085300 MOVE "A" TO ACT-U1
- 085400 MOVE "2" TO STK-RATE-U1
- 085500 MOVE RNG-SITE-ID-VR1Z TO RNG-SITE-U1
- 085600 WRITE VM-WORK-REC.
- 085700 130-CONT-PROCESS.
- 085800 PERFORM 200-PROCESS THRU 250-READ-FL-AGAIN UNTIL EOF.
- 085900 PERFORM 260-CHK-ERROR-CTR.
- 086000 CLOSE VR-VB-IN-FILE
- 086100 VR-VB-OT-FILE
- 086200 VM-WORK-FILE
- 086300 VB-WORK-FILE
- 086400 PRINTFILE.
- 086500 FINISH DIC-DE.
- 086600 STOP RUN.
- 086700 160-PRT-VB1D-HDNG.
- 086800 ADD 1 TO PAGE-CTR.
- 086900 MOVE PAGE-CTR TO HDR-PG.
- 087000 WRITE PRT-REC FROM HDR-1 AFTER ADVANCING PAGE.
- 087100 WRITE PRT-REC FROM HDR-2 AFTER ADVANCING 2 LINES.
- 087200 WRITE PRT-REC FROM VB-INST-ERR-LN1 AFTER ADVANCING 2 LINES.
- 087300 WRITE PRT-REC FROM VB-INST-ERR-LN2 AFTER ADVANCING 1 LINES.
- 087400 MOVE 6 TO LINE-CTR.
- 087500 200-PROCESS.
- 087600 210-COMP-REC-TYP.
- 087700 IF REC-TYP-HLD-2 = REC-TYP-HLD GO TO 230-EQ-REC-TYP.
- 087800 IF REC-TYP-HLD = "VR1D"
- 087900 MOVE 0 TO ERR-FREE RNGE-SITE-SAME
- 088000 MOVE 0 TO SWITCH-LINE1
- 088100 MOVE REC-TYP-HLD TO REC-TYP-HLD-2
- 088200 MOVE ADST-CD-VR1Z TO HLD-ST
- 088300 MOVE RNG-SITE-ID-VR1Z TO HLD-RNG-SITE-ID
- 088400 MOVE "VR1 EDIT ERROR LISTING" TO HDR-VR-TIT
- 088500 MOVE SPACES TO VR-HDR-ASTERISK-LN1 VR1-HDR-ASTERISK-LN2
- 088600 PERFORM 432-VALIDATE-ST-VR THRU 434-EXIT
- 088700 PERFORM 522-CHK-RNGSITE THRU 526-EXIT
- 088800 GO TO 230-EQ-REC-TYP.
- 088900 IF REC-TYP-HLD = "VR2D"
- 089000 MOVE 0 TO ERR-FREE RNGE-SITE-SAME
- 089100 MOVE 0 TO SWITCH-LINE1
- 089200 MOVE REC-TYP-HLD TO REC-TYP-HLD-2
- 089300 MOVE ADST-CD-VR2Z TO HLD-ST
- 089400 MOVE RNG-SITE-ID-VR2Z TO HLD-RNG-SITE-ID
- 089500 MOVE "VR2 EDIT ERROR LISTING" TO HDR-VR-TIT
- 089600 MOVE SPACES TO VR-HDR-ASTERISK-LN1 VR2-HDR-ASTERISK-LN2
- 089700 PERFORM 432-VALIDATE-ST-VR THRU 434-EXIT
- 089800 PERFORM 620A-CHK-RNGSITE THRU 621A-EXIT
- 089900 GO TO 230-EQ-REC-TYP.
- 090000 IF REC-TYP-HLD = "VR3D"
- 090100 MOVE 0 TO ERR-FREE RNGE-SITE-SAME
- 090200 MOVE 0 TO SWITCH-LINE1
- 090300 MOVE REC-TYP-HLD TO REC-TYP-HLD-2
- 090400 MOVE ADST-CD-VR3Z TO HLD-ST
- 090500 MOVE RNG-SITE-ID-VR3Z TO HLD-RNG-SITE-ID
- 090600 MOVE "VR3 EDIT ERROR LISTING" TO HDR-VR-TIT
- 090700 MOVE SPACES TO VR-HDR-ASTERISK-LN1 VR3-HDR-ASTERISK-LN2
- 090800 PERFORM 432-VALIDATE-ST-VR THRU 434-EXIT
- 090900 PERFORM 710-CHK-RNGSITE THRU 735-EXIT
- 091000 GO TO 230-EQ-REC-TYP.
- 091100 IF REC-TYP-HLD = "VB1D"
- 091200 MOVE 0 TO SWITCH-LINE1
- 091300 PERFORM 385-MV-TO-HLD
- 091400 MOVE "VB EDIT ERROR LISTING" TO HDR-VB-EDIT
- 091500 MOVE SPACES TO VB-ASTERISK-LN1 VB-ASTERISK-LN2
- 091600 PERFORM 435-VALIDATE-ST THRU 490-EXIT.
- 091700 230-EQ-REC-TYP.
- 091800 ADD 1 TO INPUT-CTR.
- 091900 IF REC-TYP-HLD-2 = "VB1D"
- 092000 PERFORM 320-CHK-ST-VB THRU 384-EXIT-PRT
- 092100 MOVE SPACES TO VB-ASTERISK-LN1 VB-ASTERISK-LN2
- 092200 GO TO 250-READ-FL-AGAIN.
- 092300 IF REC-TYP-HLD-2 = "VR1D"
- 092400 PERFORM 500-CHK-VR1D THRU 535-EXIT-PRT-VR1
- 092500 IF (ERR-FREE = 1) AND (RNGE-SITE-SAME = 1)
- 092600 MOVE SPACES TO VR2-HDR-ASTERISK-LN2
- 092700 GO TO 250-READ-FL-AGAIN
- 092800 ELSE
- 092900 MOVE SPACES TO VR-HDR-ASTERISK-LN1
- 093000 VR2-HDR-ASTERISK-LN2
- 093100 GO TO 250-READ-FL-AGAIN.
- 093200 IF REC-TYP-HLD-2 = "VR2D"
- 093300 PERFORM 600-CHK-VR2D THRU 675-EXIT-PRT-VR2
- 093400 IF (ERR-FREE = 1) AND (RNGE-SITE-SAME = 1)
- 093500 MOVE SPACES TO VR2-HDR-ASTERISK-LN2
- 093600 GO TO 250-READ-FL-AGAIN
- 093700 ELSE
- 093800 MOVE SPACES TO VR-HDR-ASTERISK-LN1
- 093900 VR2-HDR-ASTERISK-LN2
- 094000 GO TO 250-READ-FL-AGAIN.
- 094100 IF REC-TYP-HLD-2 = "VR3D"
- 094200 PERFORM 700-CHK-VR3D THRU 785-EXIT-PRT-VR3
- 094300 IF (ERR-FREE = 1) AND (RNGE-SITE-SAME = 1)
- 094400 MOVE SPACES TO VR2-HDR-ASTERISK-LN2
- 094500 GO TO 250-READ-FL-AGAIN
- 094600 ELSE
- 094700 MOVE SPACES TO VR-HDR-ASTERISK-LN1
- 094800 VR2-HDR-ASTERISK-LN2
- 094900 GO TO 250-READ-FL-AGAIN.
- 095000 DISPLAY REC-TYP-HLD-2.
- 095100 DISPLAY VR-VB-REC-HLD.
- 095200 250-READ-FL-AGAIN.
- 095300 READ VR-VB-IN-FILE
- 095400 AT END
- 095500 MOVE 1 TO EOF-SWITCH.
- 095600 IF (REC-TYP-I1 = "VB1D") AND
- 095700 (EOF-SWITCH = ZERO) AND
- 095800 (RNG-ECOL-COND-CLS-I1 = " ")
- 095900 MOVE "U" TO RNG-ECOL-COND-CLS-I1.
- 096000 IF EOF-SWITCH = 0
- 096100 MOVE VR-VB-IN-REC TO VR-VB-REC-HLD.
- 096200 IF (REC-TYP-I1 = "VB1D") AND
- 096300 (EOF-SWITCH = ZERO)
- 096400 ADD 1 TO VB-IN-CNT
- 096500 MOVE VR-VB-IN-REC TO VB-WORK-REC
- 096600 WRITE VB-WORK-REC.
- 096700 IF (REC-TYP-I1 = "VR1D") AND
- 096800 (EOF-SWITCH = ZERO)
- 096900 IF RNG-SITE-HLD = RNG-SITE-ID-VR1Z
- 097000 NEXT SENTENCE ELSE
- 097100 MOVE RNG-SITE-ID-VR1Z TO RNG-SITE-HLD
- 097200 MOVE SPACE TO VM-WORK-REC
- 097300 MOVE "VM1D" TO REC-TYP-U1
- 097400 MOVE ADST-CD-VR1Z TO ST-U1
- 097500 MOVE DIST-CD-VR1Z TO DS-U1
- 097600 MOVE DATA-DATE-VR1Z TO DATE-U1
- 097700 MOVE "A" TO ACT-U1
- 097800 MOVE "2" TO STK-RATE-U1
- 097900 MOVE RNG-SITE-ID-VR1Z TO RNG-SITE-U1
- 098000 WRITE VM-WORK-REC.
- 098100 260-CHK-ERROR-CTR.
- 098200 IF ERROR-CTR = ZERO
- 098300 DISPLAY " NO ERRORS DETECTED ON THESE RECORDS"
- 098400 ELSE
- 098500 MOVE INPUT-CTR TO INPUT-CTR-P
- 098600 MOVE GOOD-CTR TO GOOD-CNTR-P
- 098700 MOVE ERROR-CTR TO BAD-CNTR-P
- 098800 WRITE PRT-REC FROM PRT-RESULT-ERROR AFTER ADVANCING
- 098900 2 LINES
- 099000 ADD 2 TO LINE-CTR.
- 099100 275-WRT-HDR-ST.
- 099200 WRITE PRT-REC FROM VR-INST-ERR-LN1 AFTER ADVANCING 2 LINES.
- 099300 WRITE PRT-REC FROM VR-INST-ERR-LN2 AFTER ADVANCING 1 LINES.
- 099400 ADD 3 TO LINE-CTR.
- 099500 320-CHK-ST-VB.
- 099600 IF HLD-ST = ADST-CD-VB1Z NEXT SENTENCE
- 099700 ELSE
- 099800 PERFORM 435-VALIDATE-ST THRU 490-EXIT
- 099900 MOVE 0 TO PAGE-CTR
- 100000 PERFORM 430-PRT-HEADING2
- 100100 MOVE 0 TO SWITCH-LINE1
- 100200 PERFORM 385-MV-TO-HLD
- 100300 GO TO 370-EDIT-VB1D.
- 100400 330-CHK-DIST-VB.
- 100500 IF HLD-DIST = DIST-CD-VB1Z NEXT SENTENCE
- 100600 ELSE
- 100700 PERFORM 435-VALIDATE-ST THRU 490-EXIT
- 100800 MOVE 0 TO PAGE-CTR
- 100900 PERFORM 430-PRT-HEADING2
- 101000 MOVE 0 TO SWITCH-LINE1
- 101100 PERFORM 385-MV-TO-HLD
- 101200 GO TO 370-EDIT-VB1D.
- 101300 340-CHK-RA-VB.
- 101400 IF HLD-RA = RA-CD-VB1Z NEXT SENTENCE
- 101500 ELSE
- 101600 PERFORM 435-VALIDATE-ST THRU 490-EXIT
- 101700 MOVE 0 TO SWITCH-LINE1
- 101800 PERFORM 385-MV-TO-HLD
- 101900 GO TO 370-EDIT-VB1D.
- 102000 350-CHK-PU-VB.
- 102100 IF HLD-PU = PU-CD-VB1Z NEXT SENTENCE
- 102200 ELSE
- 102300 PERFORM 435-VALIDATE-ST THRU 490-EXIT
- 102400 MOVE 0 TO SWITCH-LINE1
- 102500 PERFORM 385-MV-TO-HLD
- 102600 GO TO 370-EDIT-VB1D.
- 102700 360-CHK-CLMTC-ADJ-FCTR.
- 102800 IF HLD-CLMTC-ADJ-FCTR = CLMTC-ADJ-FCTR-VB1Z NEXT SENTENCE
- 102900 ELSE
- 103000 MOVE 0 TO SWITCH-LINE1
- 103100 PERFORM 385-MV-TO-HLD.
- 103200 370-EDIT-VB1D.
- 103300 IF REC-TYP-HLD-2 NOT = "VB1D"
- 103400 MOVE ALL "*" TO REC-TYP-ERR.
- 103500 IF HLD-CLMTC-ADJ-FCTR NOT NUMERIC
- 103600 OR HLD-CLMTC-ADJ-FCTR NOT > ZERO
- 103700 MOVE ALL "*" TO CLIMATIC-ADJ-ERR.
- 103800 IF ACTION-CD-VB1Z NOT = "A" AND "D"
- 103900 MOVE "*" TO ACTN-ERR.
- 104000 IF SWA-CD-VB1Z NOT ALPHABETIC
- 104100 OR SWA-CD-VB1Z = SPACE
- 104200 MOVE ALL "*" TO VB-SWA-ERR.
- 104300 IF SWA-NUM-VB1Z NOT NUMERIC
- 104400 IF SWA-NUM-VB1Z = SPACES
- 104500 MOVE ZEROS TO SWA-NUM-VB1Z
- 104600 ELSE
- 104700 MOVE ALL "*" TO VB-SWA-ERR.
- 104800 IF TRN-NUM-VB1Z NOT NUMERIC
- 104900 IF TRN-NUM-VB1Z = SPACES
- 105000 MOVE ZEROS TO TRN-NUM-VB1Z
- 105100 ELSE
- 105200 MOVE ALL "*" TO VB-TRNSCT-ERR.
- 105300 IF SWA-PCT-VB1Z LESS THAN "001" OR
- 105400 SWA-PCT-VB1Z GREATER THAN "100"
- 105500 MOVE ALL "*" TO VB-PCT-SWA-ERR.
- 105600 IF STRATUM-NUMER-VB1Z NOT NUMERIC OR
- 105700 STRATUM-NUMER-VB1Z NOT GREATER THAN ZERO
- 105800 MOVE ALL "*" TO VB-STRTUM-ERR.
- 105900 IF RNG-SITE-ID-VB1Z = SPACES OR ZEROS
- 106000 MOVE ALL "*" TO VB-RNGE-SITE-ERR.
- 106100 EXAMINE RNG-SITE-ID-VB1Z TALLYING UNTIL FIRST SPACE.
- 106200 MOVE TALLY TO RNG-SITE-TALLY.
- 106300 EXAMINE RNG-SITE-ID-VB1Z TALLYING ALL SPACES.
- 106400 ADD TALLY TO RNG-SITE-TALLY.
- 106500 IF RNG-SITE-TALLY NOT = 11
- 106600 MOVE ALL "*" TO VB-RNGE-SITE-ERR.
- 106700 IF RNG-SITE-ID-4-VB1Z = "G58C" OR "G59C"
- 106800 GO TO 370B-CHK-RNGSITE-VB1D.
- 106900 MOVE RNG-SITE-ID-4-VB1Z TO DE-CD-8822-DEC.
- 107000 MOVE "3902" TO DE-NO-8801-DEC.
- 107100 FIND ANY CODE-DEC.
- 107200 MOVE DB-STATUS TO DB-STAT.
- 107300 IF NOT OK
- 107400 MOVE ALL "*" TO VB-RNGSITE-ERR-4.
- 107500 370B-CHK-RNGSITE-VB1D.
- 107600 IF RNG-SITE-ID-3-VB1Z NOT NUMERIC
- 107700 MOVE ALL "*" TO VB-RNGSITE-ERR-3.
- 107800 IF ALLOT-NUM-VB1Z
- 107900 NOT NUMERIC
- 108000 MOVE ALL "*" TO VB-ALLOT-ERR.
- 108100 IF PASTURE-NUM-VB1Z NOT NUMERIC
- 108200 IF PASTURE-NUM-VB1Z = SPACES
- 108300 MOVE ZEROS TO PASTURE-NUM-VB1Z
- 108400 ELSE
- 108500 MOVE ALL "*" TO VB-PASTURE-ERR.
- 108600 371-CHK-VEG.
- 108700 IF VEG-SUB-TYP-VB1Z = SPACES GO TO 372-CHK-COND-CLS.
- 108800 MOVE VEG-SUB-TYP-VB1Z TO DE-CD-8822-DEC.
- 108900 MOVE 2706 TO DE-NO-8801-DEC.
- 109000 FIND ANY CODE-DEC.
- 109100 MOVE DB-STATUS TO DB-STAT.
- 109200 IF NOT OK
- 109300 MOVE ALL "*" TO VB-VEG-SUB-ERR.
- 109400 372-CHK-COND-CLS.
- 109500 IF RNG-ECOL-COND-CLS-VB1Z = " "
- 109600 MOVE "U" TO RNG-ECOL-COND-CLS-VB1Z.
- 109700 IF BLM-ADM-U-VB1Z NOT = "CA026804" NEXT SENTENCE
- 109800 ELSE IF RNG-ECOL-COND-CLS-VB1Z = "S" OR "M" OR "D"
- 109900 GO TO 373-CHK-PCT-SLP.
- 110000 IF RNG-ECOL-COND-CLS-VB1Z NOT =
- 110100 "E" AND "F" AND "G" AND "P" AND "U"
- 110200 MOVE "*" TO VB-COND-CL-ERR.
- 110300 373-CHK-PCT-SLP.
- 110400 IF PCT-SLP-VB1Z = SPACES GO TO 374-CHK-ASPT.
- 110500 IF PCT-SLP-VB1Z NOT NUMERIC
- 110600 MOVE ZEROS TO PCT-SLP-VB1Z
- 110700 MOVE ALL "*" TO VB-PCT-SLOPE-ERR.
- 110800 374-CHK-ASPT.
- 110900 IF ASPT-VB1Z = SPACES GO TO 374A-CHK-L-FORM.
- 111000 MOVE ASPT-VB1Z TO DE-CD-8822-DEC.
- 111100 MOVE 6523 TO DE-NO-8801-DEC.
- 111200 FIND ANY CODE-DEC.
- 111300 IF NOT OK
- 111400 MOVE ALL "*" TO VB-SLOPE-ASP-ERR.
- 111500 374A-CHK-L-FORM.
- 111600 IF L-FORM-VB1Z = SPACES GO TO 380-EXIT.
- 111700 MOVE L-FORM-VB1Z TO DE-CD-8822-DEC.
- 111800 MOVE 5132 TO DE-NO-8801-DEC.
- 111900 FIND ANY CODE-DEC.
- 112000 MOVE DB-STATUS TO DB-STAT.
- 112100 IF NOT OK
- 112200 MOVE ALL "*" TO VB-LAND-FORM-ERR.
- 112300 380-EXIT.
- 112400 EXIT.
- 112500 382-CHK-TWO-LINES.
- 112600 IF VB-ASTERISK-LN1 = SPACES AND
- 112700 VB-ASTERISK-LN2 = SPACES
- 112800 WRITE VR-VB-OT-REC FROM VR-VB-REC-HLD
- 112900 ADD 1 TO GOOD-CTR
- 113000 GO TO 384-EXIT-PRT.
- 113100 ADD 1 TO ERROR-CTR.
- 113200 IF SWITCH-LINE1 = 1
- 113300 PERFORM 400-WRITE-ERROR-VB
- 113400 GO TO 384-EXIT-PRT
- 113500 ELSE
- 113600 MOVE 1 TO SWITCH-LINE1
- 113700 PERFORM 160-PRT-VB1D-HDNG
- 113800 PERFORM 390-MV-HDR-DET1
- 113900 WRITE PRT-REC FROM VB-HDR-REC1 AFTER ADVANCING 2 LINES.
- 114000 WRITE PRT-REC FROM VB-HDR-REC2 AFTER ADVANCING 1 LINES.
- 114100 WRITE PRT-REC FROM VB-HDR-REC3 AFTER ADVANCING 1 LINES.
- 114200 WRITE PRT-REC FROM VB-DET-LN1 AFTER ADVANCING 2 LINES.
- 114300 WRITE PRT-REC FROM VB-ASTERISK-LN1 AFTER ADVANCING
- 114400 2 LINES.
- 114500 WRITE PRT-REC FROM VB-HDR-REC4 AFTER ADVANCING 2 LINES.
- 114600 WRITE PRT-REC FROM VB-HDR-REC5 AFTER ADVANCING 1 LINES.
- 114700 WRITE PRT-REC FROM VB-HDR-REC6 AFTER ADVANCING 1 LINES.
- 114800 ADD 12 TO LINE-CTR.
- 114900 PERFORM 400-WRITE-ERROR-VB.
- 115000 384-EXIT-PRT.
- 115100 EXIT.
- 115200 385-MV-TO-HLD.
- 115300 MOVE REC-TYP-HLD TO REC-TYP-HLD-2.
- 115400 MOVE ADST-CD-VB1Z TO HLD-ST.
- 115500 MOVE DIST-CD-VB1Z TO HLD-DIST.
- 115600 MOVE RA-CD-VB1Z TO HLD-RA.
- 115700 MOVE PU-CD-VB1Z TO HLD-PU.
- 115800 MOVE CLMTC-ADJ-FCTR-VB1Z TO HLD-CLMTC-ADJ-FCTR.
- 115900 390-MV-HDR-DET1.
- 116000 MOVE SPACES TO VB-DET-LN1.
- 116100 MOVE REC-TYP-HLD-2 TO REC-TYP-P.
- 116200 MOVE HLD-ST TO ST-P.
- 116300 MOVE HLD-DIST TO DIST-P.
- 116400 MOVE HLD-RA TO RS-P.
- 116500 MOVE HLD-PU TO PU-P.
- 116600 MOVE HLD-CLMTC-ADJ-FCTR TO CLIMATIC-ADJ-P.
- 116700 MOVE DATA-DATE-VB1Z TO DATE-P.
- 116800 MOVE ACTION-CD-VB1Z TO ACTN-P.
- 116900 400-WRITE-ERROR-VB.
- 117000 MOVE SPACES TO VB-DET-LN2.
- 117100 IF LINE-CTR > 50
- 117200 PERFORM 160-PRT-VB1D-HDNG
- 117300 WRITE PRT-REC FROM VB-HDR-REC4 AFTER ADVANCING 2 LINES
- 117400 WRITE PRT-REC FROM VB-HDR-REC5 AFTER ADVANCING 1 LINES
- 117500 WRITE PRT-REC FROM VB-HDR-REC6 AFTER ADVANCING 1 LINES
- 117600 ADD 4 TO LINE-CTR.
- 117700 MOVE LIN-NUM-VB1Z TO VB-LIN-NUM-P.
- 117800 MOVE SWA-VB1Z TO VB-SWA-P.
- 117900 MOVE TRN-NUM-VB1Z TO VB-TRN-P.
- 118000 MOVE SWA-PCT-VB1Z TO VB-PCT-SWA-P.
- 118100 MOVE RNG-SITE-ID-VB1Z TO VB-RNGE-SITE-P.
- 118200 MOVE STRATUM-NUMER-VB1Z TO VB-STRTUM-P.
- 118300 MOVE ALLOT-NUM-VB1Z TO VB-ALLOT-P.
- 118400 MOVE PASTURE-NUM-VB1Z TO VB-PASTURE-P.
- 118500 MOVE VEG-SUB-TYP-VB1Z TO VB-VEG-SUB-P.
- 118600 MOVE RNG-ECOL-COND-CLS-VB1Z TO VB-COND-CL-P.
- 118700 MOVE PCT-SLP-VB1Z TO VB-PCT-SLOPE-P.
- 118800 MOVE ASPT-VB1Z TO VB-SLOPE-ASP-P.
- 118900 MOVE L-FORM-VB1Z TO VB-LAND-FORM-P.
- 119000 MOVE SOIL-PHAS-VB1Z TO VB-SOIL-PHASE-P.
- 119100 WRITE PRT-REC FROM VB-DET-LN2 AFTER ADVANCING 2 LINES.
- 119200 WRITE PRT-REC FROM VB-ASTERISK-LN2 AFTER ADVANCING 1 LINES.
- 119300 ADD 3 TO LINE-CTR.
- 119400 415-CHK-TIT.
- 119500 MOVE RNG-SITE-ID-VR1Z TO HLD-RNG-SITE-ID.
- 119600 IF REC-TYP-HLD = "VR1D"
- 119700 MOVE "VR1 EDIT ERROR LISTING" TO HDR-VR-TIT
- 119800 ELSE
- 119900 IF REC-TYP-HLD = "VR2D"
- 120000 MOVE "VR2 EDIT ERROR LISTING" TO HDR-VR-TIT
- 120100 ELSE
- 120200 IF REC-TYP-HLD = "VR3D"
- 120300 MOVE "VR3-EDIT ERROR LISTING" TO HDR-VR-TIT.
- 120400 420-HEADING-ROUTINE.
- 120500 MOVE 1 TO PAGE-CTR.
- 120600 MOVE PAGE-CTR TO HDR-PG.
- 120700 WRITE PRT-REC FROM HDR-1 AFTER ADVANCING PAGE.
- 120800 WRITE PRT-REC FROM VR-HDR-ST AFTER ADVANCING 2 LINES
- 120900 MOVE 3 TO LINE-CTR.
- 121000 430-PRT-HEADING2.
- 121100 ADD 1 TO PAGE-CTR.
- 121200 MOVE PAGE-CTR TO HDR-PG.
- 121300 WRITE PRT-REC FROM HDR-1 AFTER ADVANCING PAGE.
- 121400 WRITE PRT-REC FROM VR-HDR-ST AFTER ADVANCING 2 LINES.
- 121500 MOVE 3 TO LINE-CTR.
- 121600 432-VALIDATE-ST-VR.
- 121700 MOVE ADST-CD-VR1Z TO DE-CD-8822-DEC.
- 121800 MOVE 0003 TO DE-NO-8801-DEC.
- 121900 FIND ANY CODE-DEC.
- 122000 MOVE DB-STATUS TO DB-STAT.
- 122100 IF NOT OK
- 122200 MOVE "UNKNOWN" TO HDR-VR-ST
- 122300 GO TO 434-EXIT.
- 122400 GET CODE-DEC.
- 122500 MOVE DB-STATUS TO DB-STAT.
- 122600 IF NOT OK
- 122700 DISPLAY "DIDN'T GET ST"
- 122800 DISPLAY DB-STAT
- 122900 GO TO 434-EXIT.
- 123000 MOVE DE-CD-NAM-8823-DEC TO FUNC-HLD.
- 123100 MOVE ST-NM-HLD TO HDR-VR-ST.
- 123200 434-EXIT.
- 123300 EXIT.
- 123400 435-VALIDATE-ST.
- 123500 MOVE ADST-CD-VB1Z TO DE-CD-8822-DEC.
- 123600 436-MV-ST.
- 123700 MOVE 0003 TO DE-NO-8801-DEC.
- 123800 FIND ANY CODE-DEC.
- 123900 MOVE DB-STATUS TO DB-STAT.
- 124000 IF NOT OK
- 124100 PERFORM 440-ST-NOT-FND
- 124200 GO TO 490-EXIT.
- 124300 GET CODE-DEC.
- 124400 MOVE DB-STATUS TO DB-STAT.
- 124500 IF NOT OK
- 124600 PERFORM 440-ST-NOT-FND
- 124700 GO TO 490-EXIT.
- 124800 MOVE DE-CD-NAM-8823-DEC TO FUNC-HLD.
- 124900 MOVE ST-NM-HLD TO HDR-ST-NM.
- 125000 437-VALIDATE-ST-DIST.
- 125100 MOVE SD-VB1Z TO DE-CD-8822-DEC.
- 125200 MOVE 0003 TO DE-NO-8801-DEC.
- 125300 FIND ANY CODE-DEC.
- 125400 MOVE DB-STATUS TO DB-STAT.
- 125500 IF NOT OK
- 125600 PERFORM 450-SD-NOT-FND
- 125700 GO TO 490-EXIT.
- 125800 GET CODE-DEC.
- 125900 MOVE DB-STATUS TO DB-STAT.
- 126000 IF NOT OK
- 126100 PERFORM 450-SD-NOT-FND
- 126200 GO TO 490-EXIT.
- 126300 FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
- 126400 MOVE DB-STATUS TO DB-STAT.
- 126500 IF NOT OK
- 126600 PERFORM 450-SD-NOT-FND
- 126700 GO TO 490-EXIT.
- 126800 GET CODE-EXPL-DECE.
- 126900 MOVE DB-STATUS TO DB-STAT.
- 127000 IF NOT OK
- 127100 PERFORM 450-SD-NOT-FND
- 127200 GO TO 490-EXIT.
- 127300 MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HLD.
- 127400 MOVE DIST-NM-HLD TO HDR-DIST-NM.
- 127500 438-VALIDATE-SDR.
- 127600 MOVE SDR-VB1Z TO DE-CD-8822-DEC.
- 127700 MOVE 0003 TO DE-NO-8801-DEC.
- 127800 FIND ANY CODE-DEC.
- 127900 MOVE DB-STATUS TO DB-STAT.
- 128000 IF NOT OK
- 128100 PERFORM 470-SDR-NOT-FND
- 128200 GO TO 490-EXIT.
- 128300 439-VALIDATE-SDRP.
- 128400 MOVE BLM-ADM-U-VB1Z TO DE-CD-8822-DEC.
- 128500 MOVE 0003 TO DE-NO-8801-DEC.
- 128600 FIND ANY CODE-DEC.
- 128700 MOVE DB-STATUS TO DB-STAT.
- 128800 IF NOT OK
- 128900 PERFORM 480-SDRP-NOT-FND
- 129000 GO TO 490-EXIT.
- 129100 GO TO 490-EXIT.
- 129200 440-ST-NOT-FND.
- 129300 MOVE "UNKNOWN" TO HDR-ST-NM HDR-DIST-NM.
- 129400 MOVE ALL "*" TO ST-ERR DIST-ERR RS-ERR PU-ERR.
- 129500 450-SD-NOT-FND.
- 129600 MOVE "UNKNOWN" TO HDR-DIST-NM.
- 129700 MOVE ALL "*" TO DIST-ERR RS-ERR PU-ERR.
- 129800 470-SDR-NOT-FND.
- 129900 MOVE ALL "*" TO RS-ERR PU-ERR.
- 130000 480-SDRP-NOT-FND.
- 130100 MOVE ALL "*" TO PU-ERR.
- 130200 490-EXIT.
- 130300 EXIT.
- 130400 500-CHK-VR1D.
- 130500 IF HLD-RNG-SITE-ID = RNG-SITE-ID-VR1Z NEXT SENTENCE
- 130600 ELSE
- 130700 MOVE 0 TO RNGE-SITE-SAME
- 130800 MOVE SPACES TO HDR-VR-RNG-SITE-NO-ERR
- 130900 MOVE "VR1 EDIT ERROR LISTING" TO HDR-VR-TIT
- 131000 MOVE 0 TO SWITCH-LINE1
- 131100 MOVE ADST-CD-VR1Z TO HLD-ST
- 131200 MOVE REC-TYP-HLD TO REC-TYP-HLD-2
- 131300 MOVE RNG-SITE-ID-VR1Z TO HLD-RNG-SITE-ID
- 131400 PERFORM 522-CHK-RNGSITE THRU 526-EXIT
- 131500 PERFORM 550-PRT-HDNG-VR
- 131600 GO TO 520-EDIT-VR1D.
- 131700 MOVE 1 TO RNGE-SITE-SAME.
- 131800 IF HLD-ST = ADST-CD-VR1Z NEXT SENTENCE
- 131900 ELSE
- 132000 MOVE 1 TO PAGE-CTR
- 132100 MOVE "VR1 EDIT ERROR LISTING" TO HDR-VR-TIT
- 132200 MOVE 0 TO SWITCH-LINE1
- 132300 MOVE ADST-CD-VR1Z TO HLD-ST
- 132400 MOVE REC-TYP-HLD TO REC-TYP-HLD-2
- 132500 PERFORM 550-PRT-HDNG-VR.
- 132600 520-EDIT-VR1D.
- 132700 IF REC-TYP-HLD-2 NOT = "VR1D"
- 132800 MOVE ALL "*" TO HDR-VR-REC-TYP-ERR.
- 132900 IF ACTION-CD-VR1Z NOT = "A" AND "D"
- 133000 MOVE "*" TO HDR-VR-ACTN-ERR
- 133100 GO TO 527-CHK-PRECIP.
- 133200 522-CHK-RNGSITE.
- 133300 IF RNG-SITE-ID-VR1Z = ZERO OR
- 133400 RNG-SITE-ID-VR1Z = SPACE
- 133500 MOVE ALL "*" TO HDR-VR-RNG-SITE-NO-ERR.
- 133600 MOVE RNG-SITE-ID-VR1Z TO RANGE-SITE-ID.
- 133700 EXAMINE MLRA TALLYING ALL SPACE.
- 133800 IF TALLY > ZERO
- 133900 MOVE ALL "*" TO HDR-VR-RNG-SITE-NO-ERR.
- 134000 MOVE 8 TO I.
- 134100 PERFORM 580-EXAMINE-ID UNTIL I < 1 OR RNG-CHAR (I)
- 134200 NOT = SPACE.
- 134300 EXAMINE RNG-NUM TALLYING UNTIL FIRST SPACE.
- 134400 IF I > 0
- 134500 IF TALLY NOT = I
- 134600 MOVE ALL "*" TO HDR-VR-RNG-SITE-NO-ERR.
- 134700 IF RNG-SITE-ID-4-VR1Z = "G58C" OR "G59C"
- 134800 GO TO 525-CHK-RNG-SITE-VR1Z.
- 134900 MOVE RNG-SITE-ID-4-VR1Z TO DE-CD-8822-DEC.
- 135000 MOVE "3902" TO DE-NO-8801-DEC.
- 135100 FIND ANY CODE-DEC.
- 135200 MOVE DB-STATUS TO DB-STAT.
- 135300 IF NOT OK
- 135400 MOVE ALL "*" TO VR-RNGSITE-ERR-4.
- 135500 525-CHK-RNG-SITE-VR1Z.
- 135600 IF RNG-SITE-ID-3-VR1Z NOT NUMERIC
- 135700 MOVE ALL "*" TO VR-RNGSITE-ERR-3.
- 135800 526-EXIT.
- 135900 EXIT.
- 136000 527-CHK-PRECIP.
- 136100 IF PRECIP-ZONE-VR1Z NOT NUMERIC
- 136200 AND PRECIP-ZONE-VR1Z NOT = SPACE
- 136300 MOVE ALL "*" TO VR1-PRECIP-ERR.
- 136400 IF PRECIP-ZONE-VR1Z = SPACE
- 136500 MOVE ZERO TO PRECIP-ZONE-VR1Z.
- 136600 IF SSF-VAL-AVG-VR1Z = SPACE
- 136700 MOVE ZERO TO SSF-VAL-AVG-VR1Z.
- 136800 IF SSF-VAL-AVG-VR1Z NOT NUMERIC
- 136900 AND SSF-VAL-AVG-VR1Z NOT = SPACE
- 137000 MOVE ALL "*" TO VR1-SOIL-SURF-ERR.
- 137100 IF POTN-PPA-RS-VR1Z (1) = SPACE
- 137200 MOVE ALL "*" TO VR1-AVG-YR-ERR.
- 137300 IF POTN-PPA-RS-VR1Z (1) NOT NUMERIC
- 137400 OR POTN-PPA-RS-VR1Z (1) = ZERO
- 137500 MOVE ALL "*" TO VR1-AVG-YR-ERR.
- 137600 IF POTN-PPA-RS-VR1Z (2) = SPACE
- 137700 MOVE ALL "*" TO VR1-FAVORABLE-YR-ERR.
- 137800 IF POTN-PPA-RS-VR1Z (2) NOT NUMERIC
- 137900 OR POTN-PPA-RS-VR1Z (2) = ZERO
- 138000 MOVE ALL "*" TO VR1-FAVORABLE-YR-ERR.
- 138100 IF POTN-PPA-RS-VR1Z (3) = SPACE
- 138200 MOVE ALL "*" TO VR1-UNFAVORABLE-YR-ERR.
- 138300 IF POTN-PPA-RS-VR1Z (3) NOT NUMERIC
- 138400 OR POTN-PPA-RS-VR1Z (3) = ZERO
- 138500 MOVE ALL "*" TO VR1-UNFAVORABLE-YR-ERR.
- 138600 530-CHK-VR-ERR.
- 138700 IF VR-HDR-ASTERISK-LN1 = SPACES AND
- 138800 VR1-HDR-ASTERISK-LN2 = SPACES
- 138900 WRITE VR-VB-OT-REC FROM VR1-REC-HLD
- 139000 ADD 1 TO GOOD-CTR
- 139100 GO TO 535-EXIT-PRT-VR1.
- 139200 MOVE 1 TO ERR-FREE.
- 139300 ADD 1 TO ERROR-CTR.
- 139400 IF SWITCH-LINE1 = 1
- 139500 PERFORM 590-WRT-ERROR-VR1
- 139600 GO TO 535-EXIT-PRT-VR1
- 139700 ELSE
- 139800 MOVE 1 TO SWITCH-LINE1
- 139900 PERFORM 560-PRT-HDNG
- 140000 PERFORM 275-WRT-HDR-ST
- 140100 PERFORM 585-MV-HDR-DET-VR
- 140200 WRITE PRT-REC FROM VR-HDR-REC1 AFTER ADVANCING 2 LINES.
- 140300 WRITE PRT-REC FROM VR-HDR-REC2 AFTER ADVANCING 1 LINES.
- 140400 WRITE PRT-REC FROM VR-HDR-REC3 AFTER ADVANCING 1 LINES.
- 140500 WRITE PRT-REC FROM VR-HDR-DET-LN1 AFTER ADVANCING
- 140600 2 LINES.
- 140700 WRITE PRT-REC FROM VR-HDR-ASTERISK-LN1 AFTER ADVANCING 1
- 140800 LINES.
- 140900 WRITE PRT-REC FROM VR1-HDR-REC1 AFTER ADVANCING 2 LINES.
- 141000 WRITE PRT-REC FROM VR1-HDR-REC2 AFTER ADVANCING 1 LINES.
- 141100 WRITE PRT-REC FROM VR1-HDR-REC3 AFTER ADVANCING 1 LINES.
- 141200 ADD 11 TO LINE-CTR.
- 141300 PERFORM 590-WRT-ERROR-VR1.
- 141400 535-EXIT-PRT-VR1.
- 141500 EXIT.
- 141600 550-PRT-HDNG-VR.
- 141700 PERFORM 432-VALIDATE-ST-VR THRU 434-EXIT.
- 141800 560-PRT-HDNG.
- 141900 ADD 1 TO PAGE-CTR.
- 142000 MOVE PAGE-CTR TO HDR-PG.
- 142100 WRITE PRT-REC FROM HDR-1 AFTER ADVANCING PAGE.
- 142200 WRITE PRT-REC FROM VR-HDR-ST AFTER ADVANCING 2 LINES.
- 142300 MOVE 3 TO LINE-CTR.
- 142400 580-EXAMINE-ID.
- 142500 SUBTRACT 1 FROM I.
- 142600 585-MV-HDR-DET-VR.
- 142700 MOVE SPACES TO VR-HDR-DET-LN1.
- 142800 MOVE GRP1-VR1Z TO HDR-VR-REC-TYP-P.
- 142900 MOVE ADST-CD-VR1Z TO HDR-VR-ST-P.
- 143000 MOVE DATA-DATE-VR1Z TO HDR-VR-DATE-P.
- 143100 MOVE ACTION-CD-VR1Z TO HDR-VR-ACTN-P.
- 143200 MOVE RNG-SITE-ID-VR1Z TO HDR-VR-RNG-SITE-NO-P.
- 143300 590-WRT-ERROR-VR1.
- 143400 MOVE SPACES TO VR1-HDR-DET-LN2.
- 143500 IF LINE-CTR > 50
- 143600 PERFORM 560-PRT-HDNG.
- 143700 MOVE LIN-NUM-VR1Z TO VR1-LIN-NUM-P.
- 143800 MOVE RNG-SITE-NAM-VR1Z TO VR1-RNGSITE-NM-P.
- 143900 MOVE PRECIP-ZONE-VR1Z TO VR1-PRECIP-P.
- 144000 MOVE SSF-VAL-AVG-VR1Z TO VR1-SOIL-SURF-P.
- 144100 MOVE POTN-PPA-RS-VR1Z (1) TO VR1-AVG-YR-P.
- 144200 MOVE POTN-PPA-RS-VR1Z (2) TO VR1-FAVORABLE-YR-P.
- 144300 MOVE POTN-PPA-RS-VR1Z (3) TO VR1-UNFAVORABLE-YR-P.
- 144400 WRITE PRT-REC FROM VR1-HDR-DET-LN2 AFTER ADVANCING 2 LINES.
- 144500 WRITE PRT-REC FROM VR1-HDR-ASTERISK-LN2 AFTER ADVANCING
- 144600 1 LINES.
- 144700 MOVE SPACES TO VR-HDR-ASTERISK-LN1 VR1-HDR-ASTERISK-LN2.
- 144800 ADD 3 TO LINE-CTR.
- 144900 600-CHK-VR2D.
- 145000 IF HLD-RNG-SITE-ID = RNG-SITE-ID-VR2Z NEXT SENTENCE
- 145100 ELSE
- 145200 MOVE 0 TO RNGE-SITE-SAME
- 145300 MOVE SPACES TO HDR-VR-RNG-SITE-NO-ERR
- 145400 MOVE "VR2 EDIT ERROR LISTING" TO HDR-VR-TIT
- 145500 MOVE 0 TO SWITCH-LINE1
- 145600 MOVE ADST-CD-VR2Z TO HLD-ST
- 145700 MOVE REC-TYP-HLD TO REC-TYP-HLD-2
- 145800 MOVE RNG-SITE-ID-VR2Z TO HLD-RNG-SITE-ID
- 145900 PERFORM 620A-CHK-RNGSITE THRU 621A-EXIT
- 146000 PERFORM 550-PRT-HDNG-VR
- 146100 GO TO 620-EDIT-VR2D.
- 146200 MOVE 1 TO RNGE-SITE-SAME.
- 146300 IF HLD-ST = ADST-CD-VR2Z NEXT SENTENCE
- 146400 ELSE
- 146500 MOVE 1 TO PAGE-CTR
- 146600 MOVE "VR2 EDIT ERROR LISTING" TO HDR-VR-TIT
- 146700 MOVE 0 TO SWITCH-LINE1
- 146800 MOVE ADST-CD-VR1Z TO HLD-ST
- 146900 MOVE REC-TYP-HLD TO REC-TYP-HLD-2
- 147000 PERFORM 550-PRT-HDNG-VR.
- 147100 620-EDIT-VR2D.
- 147200 IF GRP1-VR2Z NOT = "VR2D"
- 147300 MOVE ALL "*" TO HDR-VR-REC-TYP-ERR.
- 147400 IF ACTION-CD-VR2Z NOT = "A" AND "D"
- 147500 MOVE "*" TO HDR-VR-ACTN-ERR.
- 147600 GO TO 621A-CHK-PLNT-CD.
- 147700 620A-CHK-RNGSITE.
- 147800 IF RNG-SITE-ID-VR1Z = ZERO OR
- 147900 RNG-SITE-ID-VR1Z = SPACE
- 148000 MOVE ALL "*" TO HDR-VR-RNG-SITE-NO-ERR.
- 148100 MOVE RNG-SITE-ID-VR1Z TO RANGE-SITE-ID.
- 148200 EXAMINE MLRA TALLYING ALL SPACE.
- 148300 IF TALLY > ZERO
- 148400 MOVE ALL "*" TO HDR-VR-RNG-SITE-NO-ERR.
- 148500 MOVE 8 TO I.
- 148600 PERFORM 580-EXAMINE-ID UNTIL I < 1 OR RNG-CHAR (I)
- 148700 NOT = SPACE.
- 148800 EXAMINE RNG-NUM TALLYING UNTIL FIRST SPACE.
- 148900 IF I > 0
- 149000 IF TALLY NOT = I
- 149100 MOVE ALL "*" TO HDR-VR-RNG-SITE-NO-ERR.
- 149200 IF RNG-SITE-ID-4-VR1Z = "G58C" OR "G59C"
- 149300 GO TO 621-CHK-RNG-SITE-VR2Z.
- 149400 MOVE RNG-SITE-ID-4-VR1Z TO DE-CD-8822-DEC.
- 149500 MOVE "3902" TO DE-NO-8801-DEC.
- 149600 FIND ANY CODE-DEC.
- 149700 MOVE DB-STATUS TO DB-STAT.
- 149800 IF NOT OK
- 149900 MOVE ALL "*" TO VR-RNGSITE-ERR-4.
- 150000 621-CHK-RNG-SITE-VR2Z.
- 150100 IF RNG-SITE-ID-3-VR1Z NOT NUMERIC
- 150200 MOVE ALL "*" TO VR-RNGSITE-ERR-3.
- 150300 621A-EXIT.
- 150400 EXIT.
- 150500 621A-CHK-PLNT-CD.
- 150600 IF PLANT-CD-VR2Z (1) = SPACE
- 150700 MOVE SPACE TO PLANT-TYP-VR2Z (1)
- 150800 GO TO 622-CHK-PLNT-CD2.
- 150900 MOVE "2646" TO DE-NO-8801-DEC
- 151000 MOVE PLANT-CD-VR2Z (1) TO DE-CD-8822-DEC
- 151100 FIND ANY CODE-DEC
- 151200 MOVE DB-STATUS TO DB-STAT
- 151300 IF NOT OK
- 151400 IF PLANT-CD-VR2Z (1) = "BARREN"
- 151500 MOVE SPACE TO PLANT-TYP-VR2Z (1)
- 151600 GO TO 622-CHK-PLNT-CD2
- 151700 ELSE
- 151800 MOVE ALL "*" TO VR2-PLANT-CD1-ERR
- 151900 GO TO 622-CHK-PLNT-CD2.
- 152000 GET CODE-DEC.
- 152100 MOVE DB-STATUS TO DB-STAT
- 152200 IF NOT OK
- 152300 MOVE ALL "*" TO VR2-PLANT-CD1-ERR
- 152400 GO TO 622-CHK-PLNT-CD2.
- 152500 MOVE DE-CD-NAM-8823-DEC TO DICTIONARY-SEPARATE
- 152600 IF PLANT-TYP NOT = "G" AND "F" AND "S" AND "T"
- 152700 MOVE ALL "*" TO VR2-PLANT-CD1-ERR.
- 152800 MOVE PLANT-TYP TO PLANT-TYP-VR2Z (1).
- 152900 622-CHK-PLNT-CD2.
- 153000 IF PLANT-CD-VR2Z (2) = SPACE
- 153100 MOVE SPACE TO PLANT-TYP-VR2Z (2)
- 153200 GO TO 624-CHK-PLNT-CD3.
- 153300 MOVE "2646" TO DE-NO-8801-DEC
- 153400 MOVE PLANT-CD-VR2Z (2) TO DE-CD-8822-DEC
- 153500 FIND ANY CODE-DEC
- 153600 MOVE DB-STATUS TO DB-STAT
- 153700 IF NOT OK
- 153800 IF PLANT-CD-VR2Z (2) = "BARREN"
- 153900 MOVE SPACE TO PLANT-TYP-VR2Z (2)
- 154000 GO TO 624-CHK-PLNT-CD3
- 154100 ELSE
- 154200 MOVE ALL "*" TO VR2-PLANT-CD2-ERR
- 154300 GO TO 624-CHK-PLNT-CD3.
- 154400 GET CODE-DEC
- 154500 MOVE DB-STATUS TO DB-STAT
- 154600 IF NOT OK
- 154700 MOVE ALL "*" TO VR2-PLANT-CD2-ERR
- 154800 GO TO 624-CHK-PLNT-CD3.
- 154900 MOVE DE-CD-NAM-8823-DEC TO DICTIONARY-SEPARATE
- 155000 IF PLANT-TYP NOT = "G" AND "F" AND "S"
- 155100 AND "T"
- 155200 MOVE ALL "*" TO VR2-PLANT-CD2-ERR.
- 155300 MOVE PLANT-TYP TO PLANT-TYP-VR2Z (2).
- 155400 624-CHK-PLNT-CD3.
- 155500 IF PLANT-CD-VR2Z (3) = SPACE
- 155600 MOVE SPACE TO PLANT-TYP-VR2Z (3)
- 155700 GO TO 626-CHK-PLNT-CD4.
- 155800 MOVE "2646" TO DE-NO-8801-DEC
- 155900 MOVE PLANT-CD-VR2Z (3) TO DE-CD-8822-DEC
- 156000 FIND ANY CODE-DEC
- 156100 MOVE DB-STATUS TO DB-STAT
- 156200 IF NOT OK
- 156300 IF PLANT-CD-VR2Z (3) = "BARREN"
- 156400 MOVE SPACE TO PLANT-TYP-VR2Z (3)
- 156500 GO TO 626-CHK-PLNT-CD4
- 156600 ELSE
- 156700 MOVE ALL "*" TO VR2-PLANT-CD3-ERR
- 156800 GO TO 626-CHK-PLNT-CD4.
- 156900 GET CODE-DEC
- 157000 MOVE DB-STATUS TO DB-STAT
- 157100 IF NOT OK
- 157200 MOVE ALL "*" TO VR2-PLANT-CD3-ERR
- 157300 GO TO 626-CHK-PLNT-CD4.
- 157400 MOVE DE-CD-NAM-8823-DEC TO DICTIONARY-SEPARATE
- 157500 IF PLANT-TYP NOT = "G" AND "F" AND "S"
- 157600 AND "T"
- 157700 MOVE ALL "*" TO VR2-PLANT-CD3-ERR.
- 157800 MOVE PLANT-TYP TO PLANT-TYP-VR2Z (3).
- 157900 626-CHK-PLNT-CD4.
- 158000 IF PLANT-CD-VR2Z (4) = SPACE
- 158100 MOVE SPACE TO PLANT-TYP-VR2Z (4)
- 158200 GO TO 628-CHK-PCT-COMP.
- 158300 MOVE "2646" TO DE-NO-8801-DEC
- 158400 MOVE PLANT-CD-VR2Z (4) TO DE-CD-8822-DEC
- 158500 FIND ANY CODE-DEC
- 158600 MOVE DB-STATUS TO DB-STAT
- 158700 IF NOT OK
- 158800 IF PLANT-CD-VR2Z (4) = "BARREN"
- 158900 MOVE SPACE TO PLANT-TYP-VR2Z (4)
- 159000 GO TO 628-CHK-PCT-COMP
- 159100 ELSE
- 159200 MOVE ALL "*" TO VR2-PLANT-CD4-ERR
- 159300 GO TO 628-CHK-PCT-COMP.
- 159400 GET CODE-DEC
- 159500 MOVE DB-STATUS TO DB-STAT
- 159600 IF NOT OK
- 159700 MOVE ALL "*" TO VR2-PLANT-CD4-ERR
- 159800 GO TO 628-CHK-PCT-COMP.
- 159900 MOVE DE-CD-NAM-8823-DEC TO DICTIONARY-SEPARATE
- 160000 IF PLANT-TYP NOT = "G" AND "F" AND "S"
- 160100 AND "T"
- 160200 MOVE ALL "*" TO VR2-PLANT-CD4-ERR.
- 160300 MOVE PLANT-TYP TO PLANT-TYP-VR2Z (4).
- 160400 628-CHK-PCT-COMP.
- 160500 IF PLANT-CD-VR2Z (1) NOT = SPACE AND
- 160600 ((PCT-COMP-VR2Z (1) = SPACE)
- 160700 OR (PCT-COMP-VR2Z (1) NOT NUMERIC))
- 160800 MOVE ALL "*" TO VR2-COMP-PCT1-ERR.
- 160900 IF PLANT-CD-VR2Z (2) NOT = SPACE AND
- 161000 ((PCT-COMP-VR2Z (2) = SPACE)
- 161100 OR (PCT-COMP-VR2Z (2) NOT NUMERIC))
- 161200 MOVE ALL "*" TO VR2-COMP-PCT2-ERR.
- 161300 IF PLANT-CD-VR2Z (3) NOT = SPACE AND
- 161400 ((PCT-COMP-VR2Z (3) = SPACE)
- 161500 OR (PCT-COMP-VR2Z (3) NOT NUMERIC))
- 161600 MOVE ALL "*" TO VR2-COMP-PCT3-ERR.
- 161700 IF PLANT-CD-VR2Z (4) NOT = SPACE AND
- 161800 ((PCT-COMP-VR2Z (4) = SPACE)
- 161900 OR (PCT-COMP-VR2Z (4) NOT NUMERIC))
- 162000 MOVE ALL "*" TO VR2-COMP-PCT4-ERR.
- 162100 IF VR-HDR-ASTERISK-LN1 = SPACES AND
- 162200 VR2-HDR-ASTERISK-LN2 = SPACES
- 162300 WRITE VR-VB-OT-REC FROM VR2-REC-HLD
- 162400 ADD 1 TO GOOD-CTR
- 162500 GO TO 675-EXIT-PRT-VR2.
- 162600 MOVE 1 TO ERR-FREE.
- 162700 ADD 1 TO ERROR-CTR.
- 162800 IF SWITCH-LINE1 = 1
- 162900 PERFORM 690-WRT-ERROR-VR2
- 163000 GO TO 675-EXIT-PRT-VR2
- 163100 ELSE
- 163200 MOVE 1 TO SWITCH-LINE1
- 163300 PERFORM 560-PRT-HDNG
- 163400 PERFORM 275-WRT-HDR-ST
- 163500 PERFORM 585-MV-HDR-DET-VR
- 163600 WRITE PRT-REC FROM VR-HDR-REC1 AFTER ADVANCING 2 LINES.
- 163700 WRITE PRT-REC FROM VR-HDR-REC2 AFTER ADVANCING 1 LINES.
- 163800 WRITE PRT-REC FROM VR-HDR-REC3 AFTER ADVANCING 1 LINES.
- 163900 WRITE PRT-REC FROM VR-HDR-DET-LN1 AFTER ADVANCING 2
- 164000 LINES.
- 164100 WRITE PRT-REC FROM VR-HDR-ASTERISK-LN1 AFTER ADVANCING
- 164200 1 LINES.
- 164300 WRITE PRT-REC FROM VR2-HDR-REC1 AFTER ADVANCING 2 LINES.
- 164400 WRITE PRT-REC FROM VR2-HDR-REC2 AFTER ADVANCING 1 LINES.
- 164500 WRITE PRT-REC FROM VR2-HDR-REC3 AFTER ADVANCING 1 LINES.
- 164600 ADD 11 TO LINE-CTR.
- 164700 PERFORM 690-WRT-ERROR-VR2.
- 164800 675-EXIT-PRT-VR2.
- 164900 EXIT.
- 165000 690-WRT-ERROR-VR2.
- 165100 MOVE SPACES TO VR2-HDR-DET-LN2.
- 165200 IF LINE-CTR > 50
- 165300 PERFORM 560-PRT-HDNG.
- 165400 MOVE LIN-NUM-VR2Z TO VR2-LIN-NUM-P.
- 165500 MOVE PLANT-CD-VR2Z (1) TO VR2-PLANT-CD1-P.
- 165600 MOVE PCT-COMP-VR2Z (1) TO VR2-COMP-PCT1-P.
- 165700 MOVE PLANT-CD-VR2Z (2) TO VR2-PLANT-CD2-P.
- 165800 MOVE PCT-COMP-VR2Z (2) TO VR2-COMP-PCT2-P.
- 165900 MOVE PLANT-CD-VR2Z (3) TO VR2-PLANT-CD3-P.
- 166000 MOVE PCT-COMP-VR2Z (3) TO VR2-COMP-PCT3-P.
- 166100 MOVE PLANT-CD-VR2Z (4) TO VR2-PLANT-CD4-P.
- 166200 MOVE PCT-COMP-VR2Z (4) TO VR2-COMP-PCT4-P.
- 166300 WRITE PRT-REC FROM VR2-HDR-DET-LN2 AFTER ADVANCING 2 LINES.
- 166400 WRITE PRT-REC FROM VR2-HDR-ASTERISK-LN2 AFTER ADVANCING
- 166500 1 LINES.
- 166600 MOVE SPACES TO VR2-HDR-ASTERISK-LN2.
- 166700 ADD 3 TO LINE-CTR.
- 166800 700-CHK-VR3D.
- 166900 IF HLD-RNG-SITE-ID = RNG-SITE-ID-VR3Z NEXT SENTENCE
- 167000 ELSE
- 167100 MOVE 0 TO RNGE-SITE-SAME
- 167200 MOVE SPACES TO HDR-VR-RNG-SITE-NO-ERR
- 167300 MOVE "VR3 EDIT ERROR LISTING" TO HDR-VR-TIT
- 167400 MOVE 0 TO SWITCH-LINE1
- 167500 MOVE ADST-CD-VR3Z TO HLD-ST
- 167600 MOVE REC-TYP-HLD TO REC-TYP-HLD-2
- 167700 MOVE RNG-SITE-ID-VR3Z TO HLD-RNG-SITE-ID
- 167800 PERFORM 710-CHK-RNGSITE THRU 735-EXIT
- 167900 PERFORM 550-PRT-HDNG-VR
- 168000 GO TO 720-EDIT-VR3D.
- 168100 MOVE 1 TO RNGE-SITE-SAME.
- 168200 IF HLD-ST = ADST-CD-VR3Z NEXT SENTENCE
- 168300 ELSE
- 168400 MOVE 1 TO PAGE-CTR
- 168500 MOVE "VR3 EDIT ERROR LISTING" TO HDR-VR-TIT
- 168600 MOVE 0 TO SWITCH-LINE1
- 168700 MOVE ADST-CD-VR1Z TO HLD-ST
- 168800 MOVE REC-TYP-HLD TO REC-TYP-HLD-2
- 168900 PERFORM 550-PRT-HDNG-VR.
- 169000 720-EDIT-VR3D.
- 169100 IF REC-TYP-HLD-2 NOT = "VR3D"
- 169200 MOVE ALL "*" TO HDR-VR-REC-TYP-ERR.
- 169300 IF ACTION-CD-VR3Z NOT = "A" AND "D"
- 169400 MOVE "*" TO HDR-VR-ACTN-ERR.
- 169500 GO TO 740-CHK-SOIL.
- 169600 710-CHK-RNGSITE.
- 169700 IF RNG-SITE-ID-VR1Z = ZERO OR
- 169800 RNG-SITE-ID-VR1Z = SPACE
- 169900 MOVE ALL "*" TO HDR-VR-RNG-SITE-NO-ERR.
- 170000 MOVE RNG-SITE-ID-VR1Z TO RANGE-SITE-ID.
- 170100 EXAMINE MLRA TALLYING ALL SPACE.
- 170200 IF TALLY > ZERO
- 170300 MOVE ALL "*" TO HDR-VR-RNG-SITE-NO-ERR.
- 170400 MOVE 8 TO I.
- 170500 PERFORM 580-EXAMINE-ID UNTIL I < 1 OR RNG-CHAR (I)
- 170600 NOT = SPACE.
- 170700 EXAMINE RNG-NUM TALLYING UNTIL FIRST SPACE.
- 170800 IF I > 0
- 170900 IF TALLY NOT = I
- 171000 MOVE ALL "*" TO HDR-VR-RNG-SITE-NO-ERR.
- 171100 IF RNG-SITE-ID-4-VR1Z = "G58C" OR "G59C"
- 171200 GO TO 730-CHK-RNG-SITE-VR3Z.
- 171300 MOVE RNG-SITE-ID-4-VR1Z TO DE-CD-8822-DEC.
- 171400 MOVE "3902" TO DE-NO-8801-DEC.
- 171500 FIND ANY CODE-DEC.
- 171600 MOVE DB-STATUS TO DB-STAT.
- 171700 IF NOT OK
- 171800 MOVE ALL "*" TO VR-RNGSITE-ERR-4.
- 171900 730-CHK-RNG-SITE-VR3Z.
- 172000 IF RNG-SITE-ID-3-VR1Z NOT NUMERIC
- 172100 MOVE ALL "*" TO VR-RNGSITE-ERR-3.
- 172200 735-EXIT.
- 172300 EXIT.
- 172400 740-CHK-SOIL.
- 172500* IF SOIL-PHAS-VR3Z (1) NOT = SPACE
- 172600* AND SOIL-NAM-VR3Z (1) = SPACE
- 172700* MOVE ALL "*" TO VR3-SOIL-NM1-ERR.
- 172800* IF SOIL-PHAS-VR3Z (2) NOT = SPACE
- 172900* AND SOIL-NAM-VR3Z (2) = SPACE
- 173000* MOVE ALL "*" TO VR3-SOIL-NM2-ERR.
- 173100 IF VR-HDR-ASTERISK-LN1 = SPACES AND
- 173200 VR3-HDR-ASTERISK-LN2 = SPACES
- 173300 WRITE VR-VB-OT-REC FROM VR-VB-REC-HLD
- 173400 ADD 1 TO GOOD-CTR
- 173500 GO TO 785-EXIT-PRT-VR3.
- 173600 MOVE 1 TO ERR-FREE.
- 173700 ADD 1 TO ERROR-CTR.
- 173800 IF SWITCH-LINE1 = 1
- 173900 PERFORM 790-WRT-ERROR-VR3
- 174000 GO TO 785-EXIT-PRT-VR3
- 174100 ELSE
- 174200 MOVE 1 TO SWITCH-LINE1
- 174300 PERFORM 560-PRT-HDNG
- 174400 PERFORM 275-WRT-HDR-ST
- 174500 PERFORM 585-MV-HDR-DET-VR
- 174600 WRITE PRT-REC FROM VR-HDR-REC1 AFTER ADVANCING 2 LINES.
- 174700 WRITE PRT-REC FROM VR-HDR-REC2 AFTER ADVANCING 1 LINES.
- 174800 WRITE PRT-REC FROM VR-HDR-REC3 AFTER ADVANCING 1 LINES.
- 174900 WRITE PRT-REC FROM VR-HDR-DET-LN1 AFTER ADVANCING
- 175000 2 LINES.
- 175100 WRITE PRT-REC FROM VR-HDR-ASTERISK-LN1 AFTER ADVANCING
- 175200 1 LINES.
- 175300 WRITE PRT-REC FROM VR3-HDR-REC1 AFTER ADVANCING 2 LINES.
- 175400 WRITE PRT-REC FROM VR3-HDR-REC2 AFTER ADVANCING 1 LINES.
- 175500 WRITE PRT-REC FROM VR3-HDR-REC3 AFTER ADVANCING 1 LINES.
- 175600 ADD 11 TO LINE-CTR.
- 175700 PERFORM 790-WRT-ERROR-VR3.
- 175800 785-EXIT-PRT-VR3.
- 175900 EXIT.
- 176000 790-WRT-ERROR-VR3.
- 176100 MOVE SPACES TO VR3-HDR-DET-LN2.
- 176200 IF LINE-CTR > 50
- 176300 PERFORM 560-PRT-HDNG.
- 176400 MOVE LIN-NUM-VR3Z TO VR3-LIN-NUM-P.
- 176500 MOVE SOIL-PHAS-VR3Z (1) TO VR3-SOIL-PHASE1-P.
- 176600 MOVE SOIL-NAM-VR3Z (1) TO VR3-SOIL-NM1-P.
- 176700 MOVE SOIL-PHAS-VR3Z (2) TO VR3-SOIL-PHASE2-P.
- 176800 MOVE SOIL-NAM-VR3Z (2) TO VR3-SOIL-NM2-P.
- 176900 WRITE PRT-REC FROM VR3-HDR-DET-LN2 AFTER ADVANCING 2 LINES.
- 177000 WRITE PRT-REC FROM VR3-HDR-ASTERISK-LN2 AFTER ADVANCING
- 177100 1 LINES.
- 177200 ADD 3 TO LINE-CTR.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES410U.
- 000300* INITIAL EDIT/UPDATE OF LIVESTOCK (VL) AND
- 000400* WILDLIFE (VW) USE DATA.
- 000500*
- 000600 AUTHOR. CARLANDER.
- 000700 INSTALLATION. BLM.
- 000800 DATE-WRITTEN. AUGUST 1979.
- 000900 ENVIRONMENT DIVISION.
- 001000 CONFIGURATION SECTION.
- 001100 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001200 OBJECT-COMPUTER. LEVEL-66-ASCII SEQUENCE IS EBCDIC.
- 001300 INPUT-OUTPUT SECTION.
- 001400 FILE-CONTROL.
- 001500 SELECT NEW-FILE ASSIGN D1
- 001600 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001700 SELECT TRAN-FILE ASSIGN I1
- 001800 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001900 SELECT OPTIONAL PREV-FILE ASSIGN I2
- 002000 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002100 SELECT SORT-WORK ASSIGN I1 I2 I3.
- 002200 DATA DIVISION.
- 002300 FILE SECTION.
- 002400*
- 002500 FD PREV-FILE
- 002600 CODE-SET IS GBCD
- 002700 LABEL RECORDS ARE STANDARD
- 002800 DATA RECORDS ARE VL1X-RCD VW1X-RCD.
- 002900 01 VL1X-RCD.
- 003000 02 REC-TYP-3529-VL1X PIC X(02).
- 003100 02 FMT-NUM-3576-VL1X PIC X(01).
- 003200 02 FMT-CD-3579-VL1X PIC X(01).
- 003300 02 SDRP-VL1X.
- 003400 03 BLM-ADM-U-ST-0003-VL1X PIC X(02).
- 003500 03 BLM-ADM-U-DIST-0003-VL1X PIC X(02).
- 003600 03 BLM-ADM-U-RA-0003-VL1X PIC X(02).
- 003700 03 BLM-ADM-U-PLU-0003-VL1X PIC X(02).
- 003800 02 DATA-DATE-6618-VL1X PIC X(06).
- 003900 02 ACTN-CD-7350-VL1X PIC X(01).
- 004000 02 LIN-NUM-3578-VL1X PIC X(04).
- 004100 02 VL1X-DATA OCCURS 2 TIMES.
- 004200 03 ALLOT-NUM-0968-VL1X PIC X(04).
- 004300 03 PASTURE-NUM-3905-VL1X PIC X(02).
- 004400 03 ANML-GRZG-CD-3929-VL1X PIC X(02).
- 004500 03 ANML-EST-POP-3926-VL1X PIC X(05).
- 004600 03 USE-DATES-3845-1ST-VL1X PIC X(04).
- 004700 03 USE-DATES-3845-END-VL1X PIC X(04).
- 004800 02 VL1X-OPEN PIC X(13).
- 004900 01 VW1X-RCD.
- 005000 02 REC-TYP-3529-VW1X PIC X(02).
- 005100 02 FMT-NUM-3576-VW1X PIC X(01).
- 005200 02 FMT-CD-3579-VW1X PIC X(01).
- 005300 02 SDRP-VW1X.
- 005400 03 BLM-ADM-U-ST-0003-VW1X PIC X(02).
- 005500 03 BLM-ADM-U-DIST-0003-VW1X PIC X(02).
- 005600 03 BLM-ADM-U-RA-0003-VW1X PIC X(02).
- 005700 03 BLM-ADM-U-PLU-0003-VW1X PIC X(02).
- 005800 02 DATA-DATE-6618-VW1X PIC X(06).
- 005900 02 ACTN-CD-7350-VW1X PIC X(01).
- 006000 02 LIN-NUM-3578-VW1X PIC X(04).
- 006100 02 HERD-UNIT-NUM-6598-VW1X PIC X(08).
- 006200 02 ALLOT-NUM-0968-VW1X PIC X(04).
- 006300 02 HERD-UNIT-ALLOT-PCT-3927-VW1X PIC X(03).
- 006400 02 ANML-GRZG-CD-3929-VW1X PIC X(02).
- 006500 02 ANML-EST-POP-3926-VW1X PIC X(05).
- 006600 02 USE-DATES-3845-1ST-VW1X PIC X(04).
- 006700 02 USE-DATES-3845-END-VW1X PIC X(04).
- 006800 02 SWA-3507-VW1X PIC X(04) OCCURS 5 TIMES.
- 006900 02 VW1X-OPEN PIC X(05).
- 007000*
- 007100 FD TRAN-FILE
- 007200 CODE-SET IS GBCD
- 007300 LABEL RECORDS ARE STANDARD
- 007400 DATA RECORDS ARE RCD-TF.
- 007500 01 RCD-TF.
- 007600 03 REC-TYP-TF PIC X(02).
- 007700 03 FILLER PIC X(16).
- 007800 03 ACTN-CD-TF PIC X.
- 007900 03 LINE-TF PIC X(04).
- 008000 03 ALLOT-VL-TF PIC XXXX.
- 008100 03 PAST-VL-TF PIC XX.
- 008200 03 ANML-CD-VL-TF PIC XX.
- 008300 03 ALLOT-VW-TF PIC XXXX.
- 008400 03 FILLER PIC XXX.
- 008500 03 ANML-CD-VW-TF PIC XX.
- 008600 03 FILLER PIC X(38).
- 008700*
- 008800 FD NEW-FILE
- 008900 CODE-SET IS GBCD
- 009000 LABEL RECORDS ARE STANDARD
- 009100 DATA RECORDS ARE VL1Z-RCD VW1Z-RCD.
- 009200 01 VL1Z-RCD.
- 009300 02 REC-TYP-3529-VL1Z PIC X(02).
- 009400 02 FMT-NUM-3576-VL1Z PIC X(01).
- 009500 02 FMT-CD-3579-VL1Z PIC X(01).
- 009600 02 SDRP-VL1Z.
- 009700 03 BLM-ADM-U-ST-0003-VL1Z PIC X(02).
- 009800 03 BLM-ADM-U-DIST-0003-VL1Z PIC X(02).
- 009900 03 BLM-ADM-U-RA-0003-VL1Z PIC X(02).
- 010000 03 BLM-ADM-U-PLU-0003-VL1Z PIC X(02).
- 010100 02 DATA-DATE-6618-VL1Z PIC X(06).
- 010200 02 ACTN-CD-7350-VL1Z PIC X(01).
- 010300 02 LIN-NUM-3578-VL1Z PIC X(04).
- 010400 02 VL1Z-DATA OCCURS 2 TIMES.
- 010500 03 ALLOT-NUM-0968-VL1Z PIC X(04).
- 010600 03 PASTURE-NUM-3905-VL1Z PIC X(02).
- 010700 03 ANML-GRZG-CD-3929-VL1Z PIC X(02).
- 010800 03 ANML-EST-POP-3926-VL1Z PIC X(05).
- 010900 03 USE-DATES-3845-1ST-VL1Z PIC X(04).
- 011000 03 USE-DATES-3845-END-VL1Z PIC X(04).
- 011100 02 VL1Z-OPEN PIC X(13).
- 011200 01 VW1Z-RCD.
- 011300 02 REC-TYP-3529-VW1Z PIC X(02).
- 011400 02 FMT-NUM-3576-VW1Z PIC X(01).
- 011500 02 FMT-CD-3579-VW1Z PIC X(01).
- 011600 02 SDRP-VW1Z.
- 011700 03 BLM-ADM-U-ST-0003-VW1Z PIC X(02).
- 011800 03 BLM-ADM-U-DIST-0003-VW1Z PIC X(02).
- 011900 03 BLM-ADM-U-RA-0003-VW1Z PIC X(02).
- 012000 03 BLM-ADM-U-PLU-0003-VW1Z PIC X(02).
- 012100 02 DATA-DATE-6618-VW1Z PIC X(06).
- 012200 02 ACTN-CD-7350-VW1Z PIC X(01).
- 012300 02 LIN-NUM-3578-VW1Z PIC X(04).
- 012400 02 HERD-UNIT-NUM-6598-VW1Z PIC X(08).
- 012500 02 ALLOT-NUM-0968-VW1Z PIC X(04).
- 012600 02 HERD-UNIT-ALLOT-PCT-3927-VW1Z PIC X(03).
- 012700 02 ANML-GRZG-CD-3929-VW1Z PIC X(02).
- 012800 02 ANML-EST-POP-3926-VW1Z PIC X(05).
- 012900 02 USE-DATES-3845-1ST-VW1Z PIC X(04).
- 013000 02 USE-DATES-3845-END-VW1Z PIC X(04).
- 013100 02 SWA-3507-VW1Z PIC X(04) OCCURS 5 TIMES.
- 013200 02 VW1Z-OPEN PIC X(05).
- 013300*
- 013400 SD SORT-WORK
- 013500 DATA RECORD IS SORT-RCD.
- 013600 01 SORT-RCD.
- 013700 03 SORT-REC.
- 013800 05 SR-1-12.
- 013900 07 SR-1-2 PIC X(02).
- 014000 07 SR-3-12 PIC X(10).
- 014100 05 SR-13-19 PIC X(07).
- 014200 05 SR-LINE PIC X(04).
- 014300 05 SR-DATA PIC X(55).
- 014400 03 SR-KEYS.
- 014500 05 SR-ALLOT PIC XXXX.
- 014600 05 SR-PAST PIC XX.
- 014700 05 SR-ANML-CD PIC XX.
- 014800 03 FILLER PIC XXXX.
- 014900*
- 015000 WORKING-STORAGE SECTION.
- 015100 77 END-OF-TRAN PIC X(01) VALUE " ".
- 015200 77 END-OF-PREV PIC X(01) VALUE " ".
- 015300 77 LAST-LIN-NUM PIC 9(04) VALUE 0000.
- 015400 77 DATE-SW PIC X(01).
- 015500 77 DATE-MV-SW PIC X(01).
- 015600 77 TODAYS-DATE PIC X(06).
- 015700 77 SORT-SV PIC X(78) VALUE SPACES.
- 015800*
- 015900 01 PARAMETER.
- 016000 03 RELINE-CHK PIC XXX.
- 016100 03 FILLER PIC X(77).
- 016200 01 CTRS.
- 016300 02 VL-CTR PIC 99999 VALUE 0.
- 016400 02 VW-CTR PIC 99999 VALUE 0.
- 016500*
- 016600 01 DATE-WORK.
- 016700 02 DW-YY PIC X(02).
- 016800 02 DW-MM PIC X(02).
- 016900 02 DW-DD PIC X(02).
- 017000 01 MOVED-DATE.
- 017100 02 MD-DD PIC XX.
- 017200 02 MD-YY PIC XX.
- 017300 02 MD-MM PIC XX.
- 017400*
- 017500 01 TRAN-CTL.
- 017600 02 TC-1-12 PIC X(12) VALUE SPACES.
- 017700 02 TC-LINE PIC X(04) VALUE SPACES.
- 017800 01 PREV-CTL.
- 017900 02 PC-1-12 PIC X(12) VALUE SPACES.
- 018000 02 PC-13-16 PIC X(04) VALUE SPACES.
- 018100*
- 018200 01 CTL PIC X(12).
- 018300 01 CTL-SAVE PIC X(12) VALUE SPACES.
- 018400*
- 018500 01 VL1K-RCD.
- 018600 02 REC-TYP-3529-VL1K PIC X(02).
- 018700 02 FMT-NUM-3576-VL1K PIC X(01).
- 018800 02 FMT-CD-3579-VL1K PIC X(01).
- 018900 02 SDRP-VL1K.
- 019000 03 BLM-ADM-U-ST-0003-VL1K PIC X(02).
- 019100 03 BLM-ADM-U-DIST-0003-VL1K PIC X(02).
- 019200 03 BLM-ADM-U-RA-0003-VL1K PIC X(02).
- 019300 03 BLM-ADM-U-PLU-0003-VL1K PIC X(02).
- 019400 02 DATA-DATE-6618-VL1K PIC X(06).
- 019500 02 ACTN-CD-7350-VL1K PIC X(01).
- 019600 02 LIN-NUM-3578-VL1K PIC X(04).
- 019700 02 VL1K-DATA OCCURS 2 TIMES.
- 019800 03 ALLOT-NUM-0968-VL1K PIC X(04).
- 019900 03 PASTURE-NUM-3905-VL1K PIC X(02).
- 020000 03 ANML-GRZG-CD-3929-VL1K PIC X(02).
- 020100 03 ANML-EST-POP-3926-VL1K PIC X(05).
- 020200 03 USE-DATES-3845-1ST-VL1K PIC X(04).
- 020300 03 USE-DATES-3845-END-VL1K PIC X(04).
- 020400 02 VL1K-OPEN PIC X(13).
- 020500 01 VW1K-RCD.
- 020600 02 REC-TYP-3529-VW1K PIC X(02).
- 020700 02 FMT-NUM-3576-VW1K PIC X(01).
- 020800 02 FMT-CD-3579-VW1K PIC X(01).
- 020900 02 SDRP-VW1K.
- 021000 03 BLM-ADM-U-ST-0003-VW1K PIC X(02).
- 021100 03 BLM-ADM-U-DIST-0003-VW1K PIC X(02).
- 021200 03 BLM-ADM-U-RA-0003-VW1K PIC X(02).
- 021300 03 BLM-ADM-U-PLU-0003-VW1K PIC X(02).
- 021400 02 DATA-DATE-6618-VW1K PIC X(06).
- 021500 02 ACTN-CD-7350-VW1K PIC X(01).
- 021600 02 LIN-NUM-3578-VW1K PIC X(04).
- 021700 02 HERD-UNIT-NUM-6598-VW1K PIC X(08).
- 021800 02 ALLOT-NUM-0968-VW1K PIC X(04).
- 021900 02 HERD-UNIT-ALLOT-PCT-3927-VW1K PIC X(03).
- 022000 02 ANML-GRZG-CD-3929-VW1K PIC X(02).
- 022100 02 ANML-EST-POP-3926-VW1K PIC X(05).
- 022200 02 USE-DATES-3845-1ST-VW1K PIC X(04).
- 022300 02 USE-DATES-3845-END-VW1K PIC X(04).
- 022400 02 SWA-3507-VW1K PIC X(04) OCCURS 5 TIMES.
- 022500 02 VW1K-OPEN PIC X(05).
- 022600*
- 022700 PROCEDURE DIVISION.
- 022800*
- 022900 000-DRIVER SECTION.
- 023000 010-MAINLINE.
- 023100 PERFORM 100-INITIALIZE.
- 023200 PERFORM 200-SORT.
- 023300 PERFORM 990-TERMINATE.
- 023400 STOP RUN.
- 023500*
- 023600 100-INITIALIZE SECTION.
- 023700 110-OPENS.
- 023800 OPEN INPUT PREV-FILE TRAN-FILE
- 023900 OUTPUT NEW-FILE.
- 024000 MOVE ALL "9" TO PREV-CTL.
- 024100 ACCEPT TODAYS-DATE FROM DATE.
- 024200 ACCEPT PARAMETER.
- 024300*
- 024400 200-SORT SECTION.
- 024500 210-SORT-VERB.
- 024600 SORT SORT-WORK
- 024700 ASCENDING SR-1-12 SR-LINE SR-KEYS
- 024800 INPUT PROCEDURE 300-READ-FORMAT
- 024900 OUTPUT PROCEDURE 400-MATCH-UPDATE.
- 025000*
- 025100 300-READ-FORMAT SECTION.
- 025200 310-READ.
- 025300 READ TRAN-FILE
- 025400 AT END GO TO 300-EXIT.
- 025500 IF ACTN-CD-TF = SPACE
- 025600 MOVE "A" TO ACTN-CD-TF.
- 025700 MOVE RCD-TF TO SORT-RCD.
- 025800 IF (SR-LINE NOT NUMERIC) OR (SR-LINE = "0000")
- 025900 OR (RELINE-CHK = "YES")
- 026000 MOVE "9999" TO SR-LINE.
- 026100 MOVE SPACE TO SR-KEYS.
- 026200 IF REC-TYP-TF = "VL"
- 026300 MOVE ALLOT-VL-TF TO SR-ALLOT
- 026400 MOVE PAST-VL-TF TO SR-PAST
- 026500 MOVE ANML-CD-VL-TF TO SR-ANML-CD.
- 026600 IF REC-TYP-TF = "VW"
- 026700 MOVE ALLOT-VW-TF TO SR-ALLOT
- 026800 MOVE ANML-CD-VW-TF TO SR-ANML-CD.
- 026900 RELEASE SORT-RCD.
- 027000 GO TO 310-READ.
- 027100 300-EXIT.
- 027200 EXIT.
- 027300*
- 027400 400-MATCH-UPDATE SECTION.
- 027500 410-GET-FIRST-RCDS.
- 027600 PERFORM 430-RETURN-SORT.
- 027700 PERFORM 440-READ-PREV.
- 027800 420-COMPARE.
- 027900 IF TRAN-CTL IS EQUAL TO ALL "9" AND
- 028000 PREV-CTL IS EQUAL TO ALL "9"
- 028100 GO TO 400-EXIT.
- 028200 IF TRAN-CTL IS GREATER THAN PREV-CTL
- 028300 PERFORM 500-NO-TRAN
- 028400 GO TO 420-COMPARE.
- 028500 IF PREV-CTL IS GREATER THAN TRAN-CTL
- 028600 PERFORM 600-NO-PREV
- 028700 GO TO 420-COMPARE.
- 028800 IF TRAN-CTL IS EQUAL TO PREV-CTL
- 028900 PERFORM 700-MATCH.
- 029000 GO TO 420-COMPARE.
- 029100 430-RETURN-SORT.
- 029200 RETURN SORT-WORK AT END
- 029300 MOVE "X" TO END-OF-TRAN.
- 029400 IF SORT-REC = SORT-SV AND
- 029500 END-OF-TRAN NOT = "X"
- 029600 GO TO 430-RETURN-SORT.
- 029700 MOVE SORT-REC TO SORT-SV.
- 029800 IF SR-1-2 IS EQUAL TO "VL"
- 029900 MOVE SORT-REC TO VL1K-RCD
- 030000 ELSE
- 030100 MOVE SORT-REC TO VW1K-RCD.
- 030200 MOVE SORT-REC TO TRAN-CTL.
- 030300 MOVE SR-LINE TO TC-LINE.
- 030400 IF END-OF-TRAN IS EQUAL TO "X"
- 030500 MOVE ALL "9" TO TRAN-CTL.
- 030600 440-READ-PREV.
- 030700 READ PREV-FILE AT END
- 030800 MOVE "X" TO END-OF-PREV.
- 030900 MOVE VL1X-RCD TO PREV-CTL.
- 031000 MOVE LIN-NUM-3578-VL1X TO PC-13-16.
- 031100 IF END-OF-PREV = "X"
- 031200 MOVE ALL "9" TO PREV-CTL.
- 031300*
- 031400 500-NO-TRAN.
- 031500 MOVE VL1X-RCD TO VL1Z-RCD.
- 031600 PERFORM 800-ADD-TO-CTRS.
- 031700 PERFORM 920-WRITE-Z-RCD.
- 031800 PERFORM 440-READ-PREV.
- 031900*
- 032000 600-NO-PREV.
- 032100 MOVE SORT-REC TO VL1Z-RCD.
- 032200 PERFORM 800-ADD-TO-CTRS.
- 032300 PERFORM 830-CHECK-LIN-NUM THRU 830-OUT.
- 032400 PERFORM 890-EDIT-DATE.
- 032500 PERFORM 920-WRITE-Z-RCD.
- 032600 PERFORM 430-RETURN-SORT.
- 032700*
- 032800 700-MATCH.
- 032900 MOVE VL1X-RCD TO VL1Z-RCD.
- 033000 PERFORM 890-EDIT-DATE.
- 033100 IF SR-DATA NOT = SPACES AND
- 033200 REC-TYP-3529-VL1Z = "VL"
- 033300 PERFORM 850-MOVE-VL-FIELDS
- 033400 PERFORM 800-ADD-TO-CTRS
- 033500 PERFORM 920-WRITE-Z-RCD.
- 033600 IF SR-DATA NOT = SPACES AND
- 033700 REC-TYP-3529-VL1Z = "VW"
- 033800 PERFORM 860-MOVE-VW-FIELDS
- 033900 PERFORM 800-ADD-TO-CTRS
- 034000 PERFORM 920-WRITE-Z-RCD.
- 034100 PERFORM 430-RETURN-SORT.
- 034200 PERFORM 440-READ-PREV.
- 034300*
- 034400 800-ADD-TO-CTRS.
- 034500 IF REC-TYP-3529-VL1Z = "VL"
- 034600 ADD 1 TO VL-CTR
- 034700 ELSE
- 034800 ADD 1 TO VW-CTR.
- 034900*
- 035000 830-CHECK-LIN-NUM.
- 035100 IF LIN-NUM-3578-VL1Z NOT = ALL "9"
- 035200 GO TO 830-OUT.
- 035300 MOVE VL1Z-RCD TO CTL.
- 035400 IF CTL NOT = CTL-SAVE
- 035500 MOVE 0001 TO LAST-LIN-NUM
- 035600 MOVE "0001" TO LIN-NUM-3578-VL1Z
- 035700 ELSE
- 035800 ADD 1 TO LAST-LIN-NUM
- 035900 MOVE LAST-LIN-NUM TO LIN-NUM-3578-VL1Z.
- 036000 MOVE CTL TO CTL-SAVE.
- 036100 830-OUT.
- 036200 EXIT.
- 036300*
- 036400 850-MOVE-VL-FIELDS.
- 036500 IF ALLOT-NUM-0968-VL1K (1) = SPACES
- 036600 NEXT SENTENCE
- 036700 ELSE
- 036800 IF ALLOT-NUM-0968-VL1K (1) = "****"
- 036900 MOVE SPACES TO ALLOT-NUM-0968-VL1Z (1)
- 037000 ELSE
- 037100 MOVE ALLOT-NUM-0968-VL1K (1) TO ALLOT-NUM-0968-VL1Z (1).
- 037200 IF PASTURE-NUM-3905-VL1K (1) = SPACES
- 037300 NEXT SENTENCE
- 037400 ELSE
- 037500 IF PASTURE-NUM-3905-VL1K (1) = "**"
- 037600 MOVE SPACES TO PASTURE-NUM-3905-VL1Z (1)
- 037700 ELSE
- 037800 MOVE PASTURE-NUM-3905-VL1K (1) TO PASTURE-NUM-3905-VL1Z (1).
- 037900 IF ANML-GRZG-CD-3929-VL1K (1) = SPACES
- 038000 NEXT SENTENCE
- 038100 ELSE
- 038200 IF ANML-GRZG-CD-3929-VL1K (1) = "**"
- 038300 MOVE SPACES TO ANML-GRZG-CD-3929-VL1Z (1)
- 038400 ELSE
- 038500 MOVE ANML-GRZG-CD-3929-VL1K (1) TO
- 038600 ANML-GRZG-CD-3929-VL1Z (1).
- 038700 IF ANML-EST-POP-3926-VL1K (1) = SPACES
- 038800 NEXT SENTENCE
- 038900 ELSE
- 039000* IF ANML-EST-POP-3926-VL1K (1) = "*****"
- 039100 IF ANML-EST-POP-3926-VL1K (1) = "00000"
- 039200 MOVE SPACES TO ANML-EST-POP-3926-VL1Z (1)
- 039300 ELSE
- 039400 MOVE ANML-EST-POP-3926-VL1K (1) TO
- 039500 ANML-EST-POP-3926-VL1Z (1).
- 039600 IF USE-DATES-3845-END-VL1K (1) = SPACES
- 039700 NEXT SENTENCE
- 039800 ELSE
- 039900 IF USE-DATES-3845-END-VL1K (1) = "****"
- 040000 MOVE SPACES TO USE-DATES-3845-END-VL1Z (1)
- 040100 ELSE
- 040200 MOVE USE-DATES-3845-END-VL1K (1) TO
- 040300 USE-DATES-3845-END-VL1Z (1).
- 040400 IF USE-DATES-3845-1ST-VL1K (1) = SPACES
- 040500 NEXT SENTENCE
- 040600 ELSE
- 040700 IF USE-DATES-3845-1ST-VL1K (1) = "****"
- 040800 MOVE SPACES TO USE-DATES-3845-1ST-VL1Z (1)
- 040900 ELSE
- 041000 MOVE USE-DATES-3845-1ST-VL1K (1) TO
- 041100 USE-DATES-3845-1ST-VL1Z (1).
- 041200 IF ALLOT-NUM-0968-VL1K (2) = SPACES
- 041300 NEXT SENTENCE
- 041400 ELSE
- 041500 IF ALLOT-NUM-0968-VL1K (2) = "****"
- 041600 MOVE SPACES TO ALLOT-NUM-0968-VL1Z (2)
- 041700 ELSE
- 041800 MOVE ALLOT-NUM-0968-VL1K (2) TO ALLOT-NUM-0968-VL1Z (2).
- 041900 IF PASTURE-NUM-3905-VL1K (2) = SPACES
- 042000 NEXT SENTENCE
- 042100 ELSE
- 042200 IF PASTURE-NUM-3905-VL1K (2) = "**"
- 042300 MOVE SPACES TO PASTURE-NUM-3905-VL1Z (2)
- 042400 ELSE
- 042500 MOVE PASTURE-NUM-3905-VL1K (2) TO PASTURE-NUM-3905-VL1Z (2).
- 042600 IF ANML-GRZG-CD-3929-VL1K (2) = SPACES
- 042700 NEXT SENTENCE
- 042800 ELSE
- 042900 IF ANML-GRZG-CD-3929-VL1K (2) = "**"
- 043000 MOVE SPACES TO ANML-GRZG-CD-3929-VL1Z (2)
- 043100 ELSE
- 043200 MOVE ANML-GRZG-CD-3929-VL1K (2) TO
- 043300 ANML-GRZG-CD-3929-VL1Z (2).
- 043400 IF ANML-EST-POP-3926-VL1K (2) = SPACES
- 043500 NEXT SENTENCE
- 043600 ELSE
- 043700* IF ANML-EST-POP-3926-VL1K (2) = "*****"
- 043800 IF ANML-EST-POP-3926-VL1K (2) = "00000"
- 043900 MOVE SPACES TO ANML-EST-POP-3926-VL1Z (2)
- 044000 ELSE
- 044100 MOVE ANML-EST-POP-3926-VL1K (2) TO
- 044200 ANML-EST-POP-3926-VL1Z (2).
- 044300 IF USE-DATES-3845-END-VL1K (2) = SPACES
- 044400 NEXT SENTENCE
- 044500 ELSE
- 044600 IF USE-DATES-3845-END-VL1K (2) = "****"
- 044700 MOVE SPACES TO USE-DATES-3845-END-VL1Z (2)
- 044800 ELSE
- 044900 MOVE USE-DATES-3845-END-VL1K (2) TO
- 045000 USE-DATES-3845-END-VL1Z (2).
- 045100 IF USE-DATES-3845-1ST-VL1K (2) = SPACES
- 045200 NEXT SENTENCE
- 045300 ELSE
- 045400 IF USE-DATES-3845-1ST-VL1K (2) = "****"
- 045500 MOVE SPACES TO USE-DATES-3845-1ST-VL1Z (2)
- 045600 ELSE
- 045700 MOVE USE-DATES-3845-1ST-VL1K (2) TO
- 045800 USE-DATES-3845-1ST-VL1Z (2).
- 045900*
- 046000 860-MOVE-VW-FIELDS.
- 046100 IF HERD-UNIT-NUM-6598-VW1K = SPACES
- 046200 NEXT SENTENCE
- 046300 ELSE
- 046400 IF HERD-UNIT-NUM-6598-VW1K = "********"
- 046500 MOVE SPACES TO HERD-UNIT-NUM-6598-VW1Z
- 046600 ELSE
- 046700 MOVE HERD-UNIT-NUM-6598-VW1K TO
- 046800 HERD-UNIT-NUM-6598-VW1Z.
- 046900 IF ALLOT-NUM-0968-VW1K = SPACES
- 047000 NEXT SENTENCE
- 047100 ELSE
- 047200 IF ALLOT-NUM-0968-VW1K = "****"
- 047300 MOVE SPACES TO ALLOT-NUM-0968-VW1Z
- 047400 ELSE
- 047500 MOVE ALLOT-NUM-0968-VW1K TO
- 047600 ALLOT-NUM-0968-VW1Z.
- 047700 IF HERD-UNIT-ALLOT-PCT-3927-VW1K = SPACES
- 047800 NEXT SENTENCE
- 047900 ELSE
- 048000 IF HERD-UNIT-ALLOT-PCT-3927-VW1K = "***"
- 048100 MOVE SPACES TO HERD-UNIT-ALLOT-PCT-3927-VW1Z
- 048200 ELSE
- 048300 MOVE HERD-UNIT-ALLOT-PCT-3927-VW1K TO
- 048400 HERD-UNIT-ALLOT-PCT-3927-VW1Z.
- 048500 IF ANML-GRZG-CD-3929-VW1K = SPACES
- 048600 NEXT SENTENCE
- 048700 ELSE
- 048800 IF ANML-GRZG-CD-3929-VW1K = "**"
- 048900 MOVE SPACES TO ANML-GRZG-CD-3929-VW1Z
- 049000 ELSE
- 049100 MOVE ANML-GRZG-CD-3929-VW1K TO
- 049200 ANML-GRZG-CD-3929-VW1Z.
- 049300 IF ANML-EST-POP-3926-VW1K = SPACES
- 049400 NEXT SENTENCE
- 049500 ELSE
- 049600 IF ANML-EST-POP-3926-VW1K = "*****"
- 049700 MOVE SPACES TO ANML-EST-POP-3926-VW1Z
- 049800 ELSE
- 049900 MOVE ANML-EST-POP-3926-VW1K TO
- 050000 ANML-EST-POP-3926-VW1Z.
- 050100 IF USE-DATES-3845-1ST-VW1K = SPACES
- 050200 NEXT SENTENCE
- 050300 ELSE
- 050400 IF USE-DATES-3845-1ST-VW1K = "****"
- 050500 MOVE SPACES TO USE-DATES-3845-1ST-VW1Z
- 050600 ELSE
- 050700 MOVE USE-DATES-3845-1ST-VW1K TO
- 050800 USE-DATES-3845-1ST-VW1Z.
- 050900 IF USE-DATES-3845-END-VW1K = SPACES
- 051000 NEXT SENTENCE
- 051100 ELSE
- 051200 IF USE-DATES-3845-END-VW1K = "****"
- 051300 MOVE SPACES TO USE-DATES-3845-END-VW1Z
- 051400 ELSE
- 051500 MOVE USE-DATES-3845-END-VW1K TO
- 051600 USE-DATES-3845-END-VW1Z.
- 051700 IF SWA-3507-VW1K (1) = SPACES
- 051800 NEXT SENTENCE
- 051900 ELSE
- 052000 IF SWA-3507-VW1K (1) = "****"
- 052100 MOVE SPACES TO SWA-3507-VW1Z (1)
- 052200 ELSE
- 052300 MOVE SWA-3507-VW1K (1) TO
- 052400 SWA-3507-VW1Z (1).
- 052500 IF SWA-3507-VW1K (2) = SPACES
- 052600 NEXT SENTENCE
- 052700 ELSE
- 052800 IF SWA-3507-VW1K (2) = "****"
- 052900 MOVE SPACES TO SWA-3507-VW1Z (2)
- 053000 ELSE
- 053100 MOVE SWA-3507-VW1K (2) TO
- 053200 SWA-3507-VW1Z (2).
- 053300 IF SWA-3507-VW1K (3) = SPACES
- 053400 NEXT SENTENCE
- 053500 ELSE
- 053600 IF SWA-3507-VW1K (3) = "****"
- 053700 MOVE SPACES TO SWA-3507-VW1Z (3)
- 053800 ELSE
- 053900 MOVE SWA-3507-VW1K (3) TO
- 054000 SWA-3507-VW1Z (3).
- 054100 IF SWA-3507-VW1K (4) = SPACES
- 054200 NEXT SENTENCE
- 054300 ELSE
- 054400 IF SWA-3507-VW1K (4) = "****"
- 054500 MOVE SPACES TO SWA-3507-VW1Z (4)
- 054600 ELSE
- 054700 MOVE SWA-3507-VW1K (4) TO
- 054800 SWA-3507-VW1Z (4).
- 054900 IF SWA-3507-VW1K (5) = SPACES
- 055000 NEXT SENTENCE
- 055100 ELSE
- 055200 IF SWA-3507-VW1K (5) = "****"
- 055300 MOVE SPACES TO SWA-3507-VW1Z (5)
- 055400 ELSE
- 055500 MOVE SWA-3507-VW1K (5) TO
- 055600 SWA-3507-VW1Z (5).
- 055700*
- 055800 890-EDIT-DATE.
- 055900 MOVE SPACE TO DATE-MV-SW.
- 056000 IF REC-TYP-3529-VL1Z = "VL"
- 056100 MOVE DATA-DATE-6618-VL1Z TO DATE-WORK
- 056200 ELSE
- 056300 MOVE DATA-DATE-6618-VW1Z TO DATE-WORK.
- 056400 PERFORM 900-EDIT-FIELDS.
- 056500 IF DATE-SW NOT = " "
- 056600 PERFORM 910-SWITCH-FIELDS
- 056700 PERFORM 900-EDIT-FIELDS.
- 056800 IF DATE-SW NOT = " " AND
- 056900 REC-TYP-3529-VL1Z = "VL"
- 057000 MOVE TODAYS-DATE TO DATA-DATE-6618-VL1Z.
- 057100 IF DATE-SW NOT = " " AND
- 057200 REC-TYP-3529-VL1Z = "VW"
- 057300 MOVE TODAYS-DATE TO DATA-DATE-6618-VW1Z.
- 057400 IF DATE-MV-SW NOT = " " AND
- 057500 REC-TYP-3529-VL1Z = "VL"
- 057600 MOVE MOVED-DATE TO DATA-DATE-6618-VL1Z.
- 057700 IF DATE-MV-SW NOT = " " AND
- 057800 REC-TYP-3529-VL1Z = "VW"
- 057900 MOVE MOVED-DATE TO DATA-DATE-6618-VW1Z.
- 058000 900-EDIT-FIELDS.
- 058100 MOVE SPACE TO DATE-SW.
- 058200 IF DW-MM NOT NUMERIC OR
- 058300 DW-MM > "12" OR
- 058400 DW-MM < "01"
- 058500 MOVE "X" TO DATE-SW.
- 058600 IF DW-DD NOT NUMERIC OR
- 058700 DW-DD < "01" OR
- 058800 DW-DD > "31"
- 058900 MOVE "X" TO DATE-SW.
- 059000 IF DW-YY NOT NUMERIC OR
- 059100 DW-YY < "78"
- 059200 MOVE "X" TO DATE-SW.
- 059300 910-SWITCH-FIELDS.
- 059400 IF DW-DD = "78" OR "79" OR "80" OR "81" OR "82"
- 059500 MOVE DW-MM TO MD-MM
- 059600 MOVE DW-DD TO MD-DD
- 059700 MOVE DW-YY TO MD-YY
- 059800 MOVE MOVED-DATE TO DATE-WORK
- 059900 MOVE "X" TO DATE-MV-SW.
- 060000*
- 060100 920-WRITE-Z-RCD.
- 060200 MOVE VL1Z-RCD TO CTL CTL-SAVE.
- 060300 MOVE LIN-NUM-3578-VW1Z TO LAST-LIN-NUM.
- 060400 IF REC-TYP-3529-VL1Z = "VL"
- 060500 MOVE SPACES TO VL1Z-OPEN ELSE
- 060600 MOVE SPACES TO VW1Z-OPEN.
- 060700 MOVE "A" TO ACTN-CD-7350-VL1Z.
- 060800 WRITE VL1Z-RCD.
- 060900 400-EXIT.
- 061000 EXIT.
- 061100*
- 061200 990-TERMINATE SECTION.
- 061300 990-PRINT.
- 061400 DISPLAY " VL VW".
- 061500 DISPLAY VL-CTR " " VW-CTR.
- 061600 990-CLOSE.
- 061700 CLOSE PREV-FILE TRAN-FILE NEW-FILE.
- 061800*
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES415P.
- 000300* VL / VW VERIFICATION LIST
- 000400*
- 000500 AUTHOR. CORA FISCHER.
- 000600 INSTALLATION.
- 000700 DATE-WRITTEN. 7/29/80.
- 000800 DATE-COMPILED.
- 000900 ENVIRONMENT DIVISION.
- 001000 CONFIGURATION SECTION.
- 001100 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001200 OBJECT-COMPUTER. LEVEL-66-ASCII.
- 001300 INPUT-OUTPUT SECTION.
- 001400 FILE-CONTROL.
- 001500 SELECT INPUT-FILE1 ASSIGN TO I1-ES410UD1
- 001600 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001700 SELECT PRINT-FILE ASSIGN TO P1-PRINTER
- 001800 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001900 SELECT SORT-FILE ASSIGN TO S1.
- 002000 DATA DIVISION.
- 002100 SUB-SCHEMA SECTION.
- 002200 DB CODVAL2 WITHIN BLMDIC.
- 002300 FILE SECTION.
- 002400 FD INPUT-FILE1 CODE-SET IS GBCD
- 002500 LABEL RECORDS ARE STANDARD
- 002600 DATA RECORDS ARE FDR-VL FDR-VW.
- 002700 01 FDR-VL.
- 002800 03 REC-TYPE-3529-VL-I1 PIC X(02).
- 002900 03 FMT-NO-3576-VL-I1 PIC X(01).
- 003000 03 FMT-CD-3579-VL-I1 PIC X(01).
- 003100 03 ADM-UNIT-0003-VL-I1 PIC X(08).
- 003200 03 DATA-DT-6618-VL-I1 PIC X(06).
- 003300 03 ACT-CD-7350-VL-I1 PIC X(01).
- 003400 03 LINE-NO-3578-VL-I1 PIC X(04).
- 003500 03 LVSTK-USE-DATA-I1 OCCURS 2 TIMES.
- 003600 05 ALLOT-NUM-0968-VL-I1 PIC X(04).
- 003700 05 PASTURE-NUM-3905-VL-I1 PIC X(02).
- 003800 05 ANML-GRZG-CD-3929-VL-I1 PIC X(02).
- 003900 05 ANML-EST-POP-3926-VL-I1 PIC X(05).
- 004000 05 USE-DATES-3845-VL-I1.
- 004100 07 USE-MO-DT-FR-3845-VL-I1 PIC X(02).
- 004200 07 USE-DD-DT-FR-3845-VL-I1 PIC X(02).
- 004300 07 USE-MO-DT-TO-3845-VL-I1 PIC X(02).
- 004400 07 USE-DD-DT-TO-3845-VL-I1 PIC X(02).
- 004500 03 FILLER PIC X(13).
- 004600 01 FDR-VW.
- 004700 03 REC-TYPE-3529-VW-I1 PIC X(02).
- 004800 03 FMT-NO-3576-VW-I1 PIC X(01).
- 004900 03 FMT-CD-3579-VW-I1 PIC X(01).
- 005000 03 ADM-UNIT-0003-VW-I1 PIC X(08).
- 005100 03 DATA-DT-6618-VW-I1 PIC X(06).
- 005200 03 ACT-CD-7350-VW-I1 PIC X(01).
- 005300 03 LINE-NO-3578-VW-I1 PIC X(04).
- 005400 03 HERD-UNIT-NUM-6598-VW-I1 PIC X(08).
- 005500 03 ALLOT-NUM-0968-VW-I1 PIC X(04).
- 005600 03 HERD-UNIT-ALLOT-PCT-3927-VW-I1 PIC X(03).
- 005700 03 ANML-GRZG-CD-3929-VW-I1 PIC X(02).
- 005800 03 ANML-EST-POP-3926-VW-I1 PIC X(05).
- 005900 03 USE-DATES-3845-VW-I1.
- 006000 05 USE-MO-DT-FR-3845-VW-I1 PIC X(02).
- 006100 05 USE-DD-DT-FR-3845-VW-I1 PIC X(02).
- 006200 05 USE-MO-DT-TO-3845-VW-I1 PIC X(02).
- 006300 05 USE-DD-DT-FR-3845-VW-I1 PIC X(02).
- 006400 03 SWA-3507-VW-I1 PIC X(04) OCCURS 5 TIMES.
- 006500 03 FILLER PIC X(05).
- 006600 FD PRINT-FILE CODE-SET IS GBCD
- 006700 LABEL RECORDS ARE STANDARD
- 006800 DATA RECORDS IS PRT-REC.
- 006900 01 PRT-REC PIC X(132).
- 007000 SD SORT-FILE DATA RECORDS ARE S-KEY1 S-KEY2.
- 007100 01 S-KEY1.
- 007200 03 S-KEY-DATA-VL-S1.
- 007300 05 REC-TYPE-3529-VL-S1 PIC X(02).
- 007400 05 FMT-NO-3576-VL-S1 PIC X(01).
- 007500 05 FMT-CD-3579-VL-S1 PIC X(01).
- 007600 05 ADM-UNIT-0003-VL-S1.
- 007700 07 ADM-ST-0003-VL-S1 PIC X(02).
- 007800 07 ADM-DI-0003-VL-S1 PIC X(02).
- 007900 07 ADM-RA-0003-VL-S1 PIC X(02).
- 008000 07 ADM-PU-0003-VL-S1 PIC X(02).
- 008100 05 ALLOT-NUM1-0968-VL-S1 PIC X(04).
- 008200 05 PASTURE-NUM1-3905-VL-S1 PIC X(02).
- 008300 05 ANML-GRZG-CD1-3929-VL-S1 PIC X(02).
- 008400 03 DATA-DT-6618-VL-S1 PIC X(06).
- 008500 03 ACT-CD-7350-VL-S1 PIC X(01).
- 008600 03 LINE-NO-3578-VL-S1 PIC X(04).
- 008700 03 ANML-EST-POP1-3926-VL-S1 PIC X(05).
- 008800 03 ANML-EST-POP2-3926-VL-S1 PIC X(05).
- 008900 03 USE-DATES-3845-VL-S1 OCCURS 2 TIMES.
- 009000 05 USE-MO-DT-FR-3845-VL-S1 PIC X(02).
- 009100 05 USE-DD-DT-FR-3845-VL-S1 PIC X(02).
- 009200 05 USE-MO-DT-TO-3845-VL-S1 PIC X(02).
- 009300 05 USE-DD-DT-TO-3845-VL-S1 PIC X(02).
- 009400 03 ALLOT-NUM2-0968-VL-S1 PIC X(04).
- 009500 03 PASTURE-NUM2-3905-VL-S1 PIC X(02).
- 009600 03 ANML-GRZG-CD2-3929-VL-S1 PIC X(02).
- 009700 03 FILLER PIC X(13).
- 009800 01 S-KEY2.
- 009900 03 S-KEY-DATA-VW-S1.
- 010000 05 REC-TYPE-3529-VW-S1 PIC X(02).
- 010100 05 FMT-NO-3576-VW-S1 PIC X(01).
- 010200 05 FMT-CD-3579-VW-S1 PIC X(01).
- 010300 05 ADM-UNIT-0003-VW-S1.
- 010400 07 ADM-ST-0003-VW-S1 PIC X(02).
- 010500 07 ADM-DI-0003-VW-S1 PIC X(02).
- 010600 07 ADM-RA-0003-VW-S1 PIC X(02).
- 010700 07 ADM-PU-0003-VW-S1 PIC X(02).
- 010800 05 ALLOT-NUM-0968-VW-S1 PIC X(04).
- 010900 05 FILLER PIC X(02).
- 011000 05 ANML-GRZG-CD-3929-VW-S1 PIC X(02).
- 011100 03 DATA-DT-6618-VW-S1 PIC X(06).
- 011200 03 ACT-CD-7350-VW-S1 PIC X(01).
- 011300 03 LINE-NO-3578-VW-S1 PIC X(04).
- 011400 03 HERD-UNIT-NUM-6598-VW-S1 PIC X(08).
- 011500 03 HERD-UNIT-ALLOT-PCT-3927-VW-S1 PIC X(03).
- 011600 03 ANML-EST-POP-3926-VW-S1 PIC X(05).
- 011700 03 USE-DATES-3845-VW-S1.
- 011800 05 USE-MO-DT-FR-3845-VW-S1 PIC X(02).
- 011900 05 USE-DD-DT-FR-3845-VW-S1 PIC X(02).
- 012000 05 USE-MO-DT-TO-3845-VW-S1 PIC X(02).
- 012100 05 USE-DD-DT-TO-3845-VW-S1 PIC X(02).
- 012200 03 SWA-3507-VW-S1 PIC X(04) OCCURS 5 TIMES.
- 012300 03 FILLER PIC X(03).
- 012400 WORKING-STORAGE SECTION.
- 012500 77 PAGE-CNT PIC 9(05) VALUE 0.
- 012600 77 LINE-CNT PIC 9(02) VALUE 66.
- 012700 77 VL-CNT PIC 9(05) VALUE 0.
- 012800 77 VW-CNT PIC 9(05) VALUE 0.
- 012900 01 HLD-REC-TYPE PIC X(02) VALUE SPACES.
- 013000 01 MONTH-TABLE.
- 013100 03 MO-TAB.
- 013200 05 FILLER PIC X(03) VALUE "JAN".
- 013300 05 FILLER PIC X(03) VALUE "FEB".
- 013400 05 FILLER PIC X(03) VALUE "MAR".
- 013500 05 FILLER PIC X(03) VALUE "APR".
- 013600 05 FILLER PIC X(03) VALUE "MAY".
- 013700 05 FILLER PIC X(03) VALUE "JUN".
- 013800 05 FILLER PIC X(03) VALUE "JUL".
- 013900 05 FILLER PIC X(03) VALUE "AUG".
- 014000 05 FILLER PIC X(03) VALUE "SEP".
- 014100 05 FILLER PIC X(03) VALUE "OCT".
- 014200 05 FILLER PIC X(03) VALUE "NOV".
- 014300 05 FILLER PIC X(03) VALUE "DEC".
- 014400 03 MON REDEFINES MO-TAB PIC X(03) OCCURS 12 TIMES.
- 014500 01 EOF-SWITCH PIC 9 VALUE 0.
- 014600 88 EOF VALUE 1.
- 014700 01 EOR-SWITCH PIC 9 VALUE 0.
- 014800 88 EOR VALUE 1.
- 014900 01 PARAMETER PIC X(04).
- 015000 01 HLD-DT.
- 015100 03 HOLD-DT.
- 015200 05 YR-DT PIC XX.
- 015300 05 MO-DT PIC 99.
- 015400 05 DY-DT PIC XX.
- 015500 03 INV-HLD.
- 015600 05 INV-NM PIC X(20).
- 015700 05 ST-DIST-CD.
- 015800 07 ST-CD-HLD PIC X(02).
- 015900 07 DI-CD-HLD PIC X(02).
- 016000 03 EXPL-HLD.
- 016100 05 DIST-NM-HLD PIC X(12).
- 016200 03 FUNC-HLD.
- 016300 05 ST-NM-HLD PIC X(10).
- 016400 05 FILLER PIC X(14).
- 016500 COPY DBSTATUS IN TPCOBOLIB.
- 016600 01 HDR-1.
- 016700 03 FILLER PIC X(08) VALUE
- 016800 " DATE: ".
- 016900 03 HDR-MO PIC X(03).
- 017000 03 FILLER PIC X(01) VALUE SPACE.
- 017100 03 HDR-DA PIC X(02).
- 017200 03 FILLER PIC X(04) VALUE ", 19".
- 017300 03 HDR-YR PIC X(02).
- 017400 03 FILLER PIC X(21) VALUE SPACES.
- 017500 03 FILLER PIC X(47) VALUE
- 017600 "US DEPT OF INTERIOR - BUREAU OF LAND MANAGEMENT".
- 017700 03 FILLER PIC X(29) VALUE SPACES.
- 017800 03 FILLER PIC X(07) VALUE
- 017900 "PAGE: ".
- 018000 03 HDR-PG PIC ZZ,ZZ9.
- 018100 03 FILLER PIC X(02) VALUE SPACES.
- 018200 01 HDR-2.
- 018300 03 FILLER PIC X(8) VALUE
- 018400 "STATE: ".
- 018500 03 HDR-ST-CD PIC X(02).
- 018600 03 FILLER PIC X(04) VALUE SPACES.
- 018700 03 HDR-ST-NM PIC X(10).
- 018800 03 FILLER PIC X(30) VALUE SPACES.
- 018900 03 FILLER PIC X(25) VALUE
- 019000 "ECOLOGICAL SITE INVENTORY".
- 019100 03 FILLER PIC X(35) VALUE SPACES.
- 019200 03 FILLER PIC X(18) VALUE
- 019300 "PROGRAM: ES415P ".
- 019400 01 HDR-3.
- 019500 03 FILLER PIC X(08) VALUE
- 019600 " DI: ".
- 019700 03 HDR-DIST-CD PIC X(02).
- 019800 03 FILLER PIC X(04) VALUE SPACES.
- 019900 03 HDR-DIST-NM PIC X(25).
- 020000 03 FILER PIC X(79) VALUE SPACES.
- 020100 03 FILLER PIC X(14) VALUE
- 020200 "PCN: PCN415 ".
- 020300 01 HDR-4.
- 020400 03 FILLER PIC X(08) VALUE
- 020500 " INV: ".
- 020600 03 HDR-INV-CD PIC X(04).
- 020700 03 FILLER PIC X(02) VALUE SPACES.
- 020800 03 HDR-INV-NM PIC X(25).
- 020900 03 FILLER PIC X(16) VALUE SPACES.
- 021000 03 HDR-REC-TYPE PIC X(02).
- 021100 03 FILLER PIC X(18) VALUE
- 021200 " VERIFICATION LIST".
- 021300 03 FILLER PIC X(57) VALUE SPACES.
- 021400 01 HDR-5-VL.
- 021500 03 FILLER PIC X(38) VALUE
- 021600 "(1-2) (3) (4) (5)".
- 021700 03 FILLER PIC X(10) VALUE SPACES.
- 021800 03 FILLER PIC X(34) VALUE
- 021900 "(6) (7) (8) (9) (10)".
- 022000 03 FILLER PIC X(10) VALUE SPACES.
- 022100 03 FILLER PIC X(40) VALUE
- 022200 "(6) (7) (8) (9) (10) ".
- 022300 01 HDR-6-VL.
- 022400 03 FILLER PIC X(43) VALUE
- 022500 " REC ADMINISTRATIVE UNIT DATE ACT LINE".
- 022600 03 FILLER PIC X(16) VALUE SPACES.
- 022700 03 FILLER PIC X(27) VALUE
- 022800 "ANML AUTH PERIOD OF USE".
- 022900 03 FILLER PIC X(16) VALUE SPACES.
- 023000 03 FILLER PIC X(30) VALUE
- 023100 "ANML AUTH PERIOD OF USE ".
- 023200 01 HDR-7-VL.
- 023300 03 FILLER PIC X(46) VALUE
- 023400 "TYPE ST DI RA PU YYMMDD CD NUM ".
- 023500 03 FILLER PIC X(51) VALUE
- 023600 "ALLOT PAST SPEC LVSTK FROM MM DD-TO MM DD ALLOT ".
- 023700 03 FILLER PIC X(35) VALUE
- 023800 "PAST SPEC LVSTK FROM MM DD-TO MM DD".
- 023900 01 HDR-8-VL.
- 024000 03 FILLER PIC X(52) VALUE
- 024100 " 1-4 5-6 7-8 9-10 11-12 13-18 19 20-23 24-27 ".
- 024200 03 FILLER PIC X(49) VALUE
- 024300 "28-29 30-31 32-36 37-40 41-44 45-48 49-50".
- 024400 03 FILLER PIC X(31) VALUE
- 024500 " 51-2 53-57 58-61 62-65".
- 024600 01 HDR-9-VL.
- 024700 03 FILLER PIC X(53) VALUE
- 024800 "XXXX XX XX XX XX XXXXXX X 9999 9999 ".
- 024900 03 FILLER PIC X(54) VALUE
- 025000 " 99 XX 99999 XX XX XX XX 9999 99 XX ".
- 025100 03 FILLER PIC X(25) VALUE
- 025200 "99999 XX XX XX XX".
- 025300 01 HDR-10-DET-VL.
- 025400 03 REC-TYPE-3529-VL-P1 PIC X(02).
- 025500 03 FMT-NO-3576-VL-P1 PIC X(01).
- 025600 03 FMT-CD-3579-VL-P1 PIC X(01).
- 025700 03 FILLER PIC X(02) VALUE SPACES.
- 025800 03 ADM-ST-0003-VL-P1 PIC X(02).
- 025900 03 FILLER PIC X(03) VALUE SPACES.
- 026000 03 ADM-DI-0003-VL-P1 PIC X(02).
- 026100 03 FILLER PIC X(03) VALUE SPACES.
- 026200 03 ADM-RA-0003-VL-P1 PIC X(02).
- 026300 03 FILLER PIC X(03) VALUE SPACES.
- 026400 03 ADM-PU-0003-VL-P1 PIC X(02).
- 026500 03 FILLER PIC X(03) VALUE SPACES.
- 026600 03 DATA-DT-6618-VL-P1 PIC X(06).
- 026700 03 FILLER PIC X(03) VALUE SPACES.
- 026800 03 ACT-CD-7350-VL-P1 PIC X(01).
- 026900 03 FILLER PIC X(03) VALUE SPACES.
- 027000 03 LINE-NO-3578-VL-P1 PIC X(04).
- 027100 03 FILLER PIC X(04) VALUE SPACES.
- 027200 03 ALLOT-NUM1-0968-VL-P1 PIC X(04).
- 027300 03 FILLER PIC X(03) VALUE SPACES.
- 027400 03 PASTURE-NUM1-3905-VL-P1 PIC X(02).
- 027500 03 FILLER PIC X(04) VALUE SPACES.
- 027600 03 ANML-GRZG-CD1-3929-VL-P1 PIC X(02).
- 027700 03 FILLER PIC X(02) VALUE SPACES.
- 027800 03 ANML-EST-POP1-3926-VL-P1 PIC X(05).
- 027900 03 FILLER PIC X(06) VALUE SPACES.
- 028000 03 USE-MO-DT-FR1-3845-VL-P1 PIC X(02).
- 028100 03 FILLER PIC X(01) VALUE SPACE.
- 028200 03 USE-DD-DT-FR1-3845-VL-P1 PIC X(02).
- 028300 03 FILLER PIC X(04) VALUE SPACES.
- 028400 03 USE-MO-DT-TO1-3845-VL-P1 PIC X(02).
- 028500 03 FILLER PIC X(01) VALUE SPACE.
- 028600 03 USE-DD-DT-TO1-3845-VL-P1 PIC X(02).
- 028700 03 FILLER PIC X(02) VALUE SPACES.
- 028800 03 ALLOT-NUM2-0968-VL-P1 PIC X(04).
- 028900 03 FILLER PIC X(03) VALUE SPACES.
- 029000 03 PASTURE-NUM2-3905-VL-P1 PIC X(02).
- 029100 03 FILLER PIC X(03) VALUE SPACES.
- 029200 03 ANML-GRZG-CD2-3929-VL-P1 PIC X(02).
- 029300 03 FILLER PIC X(02) VALUE SPACES.
- 029400 03 ANML-EST-POP2-3926-VL-P1 PIC X(05).
- 029500 03 FILLER PIC X(06) VALUE SPACES.
- 029600 03 USE-MO-DT-FR2-3845-VL-P1 PIC X(02).
- 029700 03 FILLER PIC X(01) VALUE SPACE.
- 029800 03 USE-DD-DT-FR2-3845-VL-P1 PIC X(02).
- 029900 03 FILLER PIC X(04) VALUE SPACES.
- 030000 03 USE-MO-DT-TO2-3845-VL-P1 PIC X(02).
- 030100 03 FILLER PIC X(01) VALUE SPACE.
- 030200 03 USE-DD-DT-TO2-3845-VL-P1 PIC X(02).
- 030300 01 HDR-5-VW.
- 030400 03 FILLER PIC X(53) VALUE
- 030500 "(1-2) (3) (4) (5) (6)".
- 030600 03 FILLER PIC X(29) VALUE
- 030700 " (7) (8) (9) (10)".
- 030800 03 FILLER PIC X(10) VALUE SPACES.
- 030900 03 FILLER PIC X(4) VALUE
- 031000 "(11)".
- 031100 03 FILLER PIC X(21) VALUE SPACES.
- 031200 03 FILLER PIC X(4) VALUE "(12)".
- 031300 03 FILLER PIC X(11) VALUE SPACES.
- 031400 01 HDR-6-VW.
- 031500 03 FILLER PIC X(49) VALUE
- 031600 " REC ADMINISTRATIVE UNIT DATE ACT LINE ".
- 031700 03 FILLER PIC X(51) VALUE
- 031800 "HERD PCT ANML EST NUM PERIOD OF USE".
- 031900 03 FILLER PIC X(32) VALUE
- 032000 " LSTG OF SWAS BY WLDLF SPEC ".
- 032100 01 HDR-7-VW.
- 032200 03 FILLER PIC X(42) VALUE
- 032300 "TYPE ST DI RA PU YYMMDD CD NO".
- 032400 03 FILLER PIC X(49) VALUE
- 032500 " UNIT ALLOT HERD SPEC ANMLS FROM MM ".
- 032600 03 FILLER PIC X(40) VALUE
- 032700 "DD-TO MM DD SWA SWA SWA SWA SWA".
- 032800 01 HDR-8-VW.
- 032900 03 FILLER PIC X(54) VALUE
- 033000 " 1-4 5-6 7-8 9-10 11-12 13-18 19 20-23 24-31".
- 033100 03 FILLER PIC X(49) VALUE
- 033200 " 32-35 36-8 39-40 41-45 46-49 50-53".
- 033300 03 FILLER PIC X(29) VALUE
- 033400 " 54-7 58-61 62-5 66-9 70-3".
- 033500 01 HDR-9-VW.
- 033600 03 FILLER PIC X(47) VALUE
- 033700 "XXXX XX XX XX XX XXXXXX X XXXX ".
- 033800 03 FILLER PIC X(42) VALUE
- 033900 "XXXXXXXX 9999 999 XX 99999 ".
- 034000 03 FILLER PIC X(43) VALUE
- 034100 "XX XX XX XX XXXX XXXX XXXX XXXX XXXX".
- 034200 01 HDR-10-DET-VW.
- 034300 03 REC-TYPE-3529-VW-P1 PIC X(02).
- 034400 03 FMT-NO-3576-VW-P1 PIC X(01).
- 034500 03 FMT-CD-3579-VW-P1 PIC X(01).
- 034600 03 FILLER PIC X(02) VALUE SPACES.
- 034700 03 ADM-ST-0003-VW-P1 PIC X(02).
- 034800 03 FILLER PIC X(03) VALUE SPACES.
- 034900 03 ADM-DI-0003-VW-P1 PIC X(02).
- 035000 03 FILLER PIC X(03) VALUE SPACES.
- 035100 03 ADM-RA-0003-VW-P1 PIC X(02).
- 035200 03 FILLER PIC X(03) VALUE SPACES.
- 035300 03 ADM-PU-0003-VW-P1 PIC X(02).
- 035400 03 FILLER PIC X(04) VALUE SPACES.
- 035500 03 DATA-DT-6618-VW-P1 PIC X(06).
- 035600 03 FILLER PIC X(03) VALUE SPACES.
- 035700 03 ACT-CD-7350-VW-P1 PIC X(01).
- 035800 03 FILLER PIC X(03) VALUE SPACES.
- 035900 03 LINE-NO-3578-VW-P1 PIC X(04).
- 036000 03 FILLER PIC X(03) VALUE SPACES.
- 036100 03 HERD-UNIT-NUM-6598-VW-P1 PIC X(08).
- 036200 03 FILLER PIC X(03) VALUE SPACES.
- 036300 03 ALLOT-NUM-0968-VW-P1 PIC X(04).
- 036400 03 FILLER PIC X(03) VALUE SPACES.
- 036500 03 HERD-UNIT-ALLOT-PCT-3927-VW-P1 PIC X(03).
- 036600 03 FILLER PIC X(04) VALUE SPACES.
- 036700 03 ANML-GRZG-CD-3929-VW-P1 PIC X(02).
- 036800 03 FILLER PIC X(03) VALUE SPACES.
- 036900 03 ANML-EST-POP-3926-VW-P1 PIC X(05).
- 037000 03 FILLER PIC X(07) VALUE SPACES.
- 037100 03 USE-MO-DT-FR-3845-VW-P1 PIC X(02).
- 037200 03 FILLER PIC X(01) VALUE SPACES.
- 037300 03 USE-DD-DT-FR-3845-VW-P1 PIC X(02).
- 037400 03 FILLER PIC X(04) VALUE SPACES.
- 037500 03 USE-MO-DT-TO-3845-VW-P1 PIC X(02).
- 037600 03 FILLER PIC X(01) VALUE SPACE.
- 037700 03 USE-DD-DT-TO-3845-VW-P1 PIC X(02).
- 037800 03 FILLER PIC X(01) VALUE SPACE.
- 037900 03 SWA1-3507-VW-P1 PIC X(04).
- 038000 03 FILLER PIC X(02) VALUE SPACES.
- 038100 03 SWA2-3507-VW-P1 PIC X(04).
- 038200 03 FILLER PIC X(02) VALUE SPACES.
- 038300 03 SWA3-3507-VW-P1 PIC X(04).
- 038400 03 FILLER PIC X(02) VALUE SPACES.
- 038500 03 SWA4-3507-VW-P1 PIC X(04).
- 038600 03 FILLER PIC X(02) VALUE SPACES.
- 038700 03 SWA5-3507-VW-P1 PIC X(04).
- 038800 PROCEDURE DIVISION.
- 038900 START-SORT SECTION.
- 039000 100-SORT.
- 039100 SORT SORT-FILE ON ASCENDING S-KEY-DATA-VL-S1
- 039200 INPUT PROCEDURE PRE-SORT
- 039300 OUTPUT PROCEDURE POST-SORT.
- 039400 200-END-SECTION.
- 039500 FINISH DIC-DE.
- 039600 CLOSE PRINT-FILE.
- 039700 DISPLAY "VL-CNT " VL-CNT.
- 039800 DISPLAY "VW-CNT " VW-CNT.
- 039900 STOP RUN.
- 040000 PRE-SORT SECTION.
- 040100 300-HSKPNG.
- 040200 OPEN INPUT INPUT-FILE1.
- 040300 MOVE SPACES TO S-KEY1 S-KEY2.
- 040400 400-MAIN.
- 040500 PERFORM 500-RD-FILE1 THRU 600-EXIT-RD-FL1 UNTIL EOF.
- 040600 CLOSE INPUT-FILE1.
- 040700 GO TO 850-EXIT-VW.
- 040800 500-RD-FILE1.
- 040900 READ INPUT-FILE1 AT END MOVE 1 TO EOF-SWITCH.
- 041000 IF (EOF-SWITCH = 1) GO TO 600-EXIT-RD-FL1.
- 041100 IF REC-TYPE-3529-VL-I1 = "VL"
- 041200 PERFORM 700-MV-VL-TO-SRT THRU 750-EXIT-VL
- 041300 GO TO 600-EXIT-RD-FL1.
- 041400 IF REC-TYPE-3529-VW-I1 = "VW"
- 041500 PERFORM 800-MV-VW-TO-SRT THRU 850-EXIT-VW
- 041600 GO TO 600-EXIT-RD-FL1.
- 041700 600-EXIT-RD-FL1.
- 041800 EXIT.
- 041900 700-MV-VL-TO-SRT.
- 042000 ADD 1 TO VL-CNT.
- 042100 MOVE REC-TYPE-3529-VL-I1 TO REC-TYPE-3529-VL-S1.
- 042200 MOVE FMT-NO-3576-VL-I1 TO FMT-NO-3576-VL-S1.
- 042300 MOVE FMT-CD-3579-VL-I1 TO FMT-CD-3579-VL-S1.
- 042400 MOVE ADM-UNIT-0003-VL-I1 TO ADM-UNIT-0003-VL-S1.
- 042500 MOVE DATA-DT-6618-VL-I1 TO DATA-DT-6618-VL-S1.
- 042600 MOVE ACT-CD-7350-VL-I1 TO ACT-CD-7350-VL-S1.
- 042700 MOVE LINE-NO-3578-VL-I1 TO LINE-NO-3578-VL-S1.
- 042800 MOVE ALLOT-NUM-0968-VL-I1 (1) TO ALLOT-NUM1-0968-VL-S1.
- 042900 MOVE ALLOT-NUM-0968-VL-I1 (2) TO ALLOT-NUM2-0968-VL-S1.
- 043000 MOVE PASTURE-NUM-3905-VL-I1 (1) TO PASTURE-NUM1-3905-VL-S1.
- 043100 MOVE PASTURE-NUM-3905-VL-I1 (2) TO PASTURE-NUM2-3905-VL-S1.
- 043200 MOVE ANML-GRZG-CD-3929-VL-I1 (1) TO ANML-GRZG-CD1-3929-VL-S1.
- 043300 MOVE ANML-GRZG-CD-3929-VL-I1 (2) TO ANML-GRZG-CD2-3929-VL-S1.
- 043400 MOVE ANML-EST-POP-3926-VL-I1 (1) TO ANML-EST-POP1-3926-VL-S1.
- 043500 MOVE ANML-EST-POP-3926-VL-I1 (2) TO
- 043600 ANML-EST-POP2-3926-VL-S1.
- 043700 MOVE USE-MO-DT-FR-3845-VL-I1 (1) TO
- 043800 USE-MO-DT-FR-3845-VL-S1 (1).
- 043900 MOVE USE-MO-DT-FR-3845-VL-I1 (2) TO
- 044000 USE-MO-DT-FR-3845-VL-S1 (2).
- 044100 MOVE USE-DD-DT-FR-3845-VL-I1 (1) TO
- 044200 USE-DD-DT-FR-3845-VL-S1 (1).
- 044300 MOVE USE-DD-DT-FR-3845-VL-I1 (2) TO
- 044400 USE-DD-DT-FR-3845-VL-S1 (2).
- 044500 MOVE USE-MO-DT-TO-3845-VL-I1 (1) TO
- 044600 USE-MO-DT-TO-3845-VL-S1 (1).
- 044700 MOVE USE-MO-DT-TO-3845-VL-I1 (2) TO
- 044800 USE-MO-DT-TO-3845-VL-S1 (2).
- 044900 MOVE USE-DD-DT-TO-3845-VL-I1 (1) TO
- 045000 USE-DD-DT-TO-3845-VL-S1 (1).
- 045100 MOVE USE-DD-DT-TO-3845-VL-I1 (2) TO
- 045200 USE-DD-DT-TO-3845-VL-S1 (2).
- 045300 RELEASE S-KEY1.
- 045400 750-EXIT-VL.
- 045500 EXIT.
- 045600 800-MV-VW-TO-SRT.
- 045700 ADD 1 TO VW-CNT.
- 045800 MOVE REC-TYPE-3529-VW-I1 TO REC-TYPE-3529-VW-S1.
- 045900 MOVE FMT-NO-3576-VW-I1 TO FMT-NO-3576-VW-S1.
- 046000 MOVE FMT-CD-3579-VW-I1 TO FMT-CD-3579-VW-S1.
- 046100 MOVE ADM-UNIT-0003-VW-I1 TO ADM-UNIT-0003-VW-S1.
- 046200 MOVE DATA-DT-6618-VW-I1 TO DATA-DT-6618-VW-S1.
- 046300 MOVE ACT-CD-7350-VW-I1 TO ACT-CD-7350-VW-S1.
- 046400 MOVE LINE-NO-3578-VW-I1 TO LINE-NO-3578-VW-S1.
- 046500 MOVE HERD-UNIT-NUM-6598-VW-I1 TO HERD-UNIT-NUM-6598-VW-S1.
- 046600 MOVE ALLOT-NUM-0968-VW-I1 TO ALLOT-NUM-0968-VW-S1.
- 046700 MOVE HERD-UNIT-ALLOT-PCT-3927-VW-I1 TO
- 046800 HERD-UNIT-ALLOT-PCT-3927-VW-S1.
- 046900 MOVE ANML-GRZG-CD-3929-VW-I1 TO ANML-GRZG-CD-3929-VW-S1.
- 047000 MOVE ANML-EST-POP-3926-VW-I1 TO ANML-EST-POP-3926-VW-S1.
- 047100 MOVE USE-DATES-3845-VW-I1 TO USE-DATES-3845-VW-S1.
- 047200 MOVE SWA-3507-VW-I1(1) TO SWA-3507-VW-S1(1).
- 047300 MOVE SWA-3507-VW-I1(2) TO SWA-3507-VW-S1(2).
- 047400 MOVE SWA-3507-VW-I1(3) TO SWA-3507-VW-S1(3).
- 047500 MOVE SWA-3507-VW-I1(4) TO SWA-3507-VW-S1(4).
- 047600 MOVE SWA-3507-VW-I1(5) TO SWA-3507-VW-S1(5).
- 047700 RELEASE S-KEY2.
- 047800 850-EXIT-VW.
- 047900 EXIT.
- 048000 POST-SORT SECTION.
- 048100 3050-RET-HSKPNG.
- 048200 OPEN OUTPUT PRINT-FILE.
- 048300 ACCEPT PARAMETER.
- 048400 ACCEPT HOLD-DT FROM DATE.
- 048500 MOVE YR-DT TO HDR-YR.
- 048600 MOVE MON(MO-DT) TO HDR-MO.
- 048700 MOVE DY-DT TO HDR-DA.
- 048800 READY DIC-DE.
- 048900 PERFORM 4000-VALIDATE-INV THRU 4050-EXIT-STDI.
- 049000 RETURN SORT-FILE AT END MOVE 1 TO EOR-SWITCH.
- 049100 MOVE REC-TYPE-3529-VL-S1 TO HLD-REC-TYPE.
- 049200 PERFORM 4100-CHK-LINE-CNT THRU 4150-EXIT-LINE-OVR50.
- 049300 3070-MAIN-DRIVER.
- 049400 PERFORM 4300-DET-REC-LINE THRU 4350-EXIT-DET UNTIL EOR.
- 049500 IF (EOR-SWITCH = 1) GO TO 5000-DUMMY.
- 049600 4000-VALIDATE-INV.
- 049700 MOVE PARAMETER TO DE-CD-8822-DEC HDR-INV-CD.
- 049800 MOVE 3940 TO DE-NO-8801-DEC.
- 049900 FIND ANY CODE-DEC.
- 050000 MOVE DB-STATUS TO DB-STAT.
- 050100 IF NOT OK
- 050200 MOVE "UNKNOWN" TO HDR-ST-NM HDR-DIST-NM HDR-INV-NM
- 050300 GO TO 4050-EXIT-STDI.
- 050400 GET CODE-DEC.
- 050500 MOVE DB-STATUS TO DB-STAT.
- 050600 IF NOT OK
- 050700 DISPLAY "ES415PBD DIDN'T GET INVN"
- 050800 DISPLAY DB-STAT
- 050900 GO TO 4050-EXIT-STDI.
- 051000 MOVE DE-CD-NAM-8823-DEC TO INV-HLD.
- 051100 MOVE INV-NM TO HDR-INV-NM.
- 051200 4005-VALIDATE-ST.
- 051300 MOVE ST-CD-HLD TO DE-CD-8822-DEC HDR-ST-CD.
- 051400 MOVE 0003 TO DE-NO-8801-DEC.
- 051500 FIND ANY CODE-DEC.
- 051600 MOVE DB-STATUS TO DB-STAT.
- 051700 IF NOT OK
- 051800 MOVE "UNKNOWN" TO HDR-ST-NM
- 051900 GO TO 4008-EXIT-ST.
- 052000 GET CODE-DEC.
- 052100 MOVE DB-STATUS TO DB-STAT.
- 052200 IF NOT OK
- 052300 DISPLAY "ES415PBD 3 DIDN'T GET ST"
- 052400 DISPLAY "ES415PBD 4 " DB-STAT
- 052500 GO TO 4008-EXIT-ST.
- 052600 MOVE DE-CD-NAM-8823-DEC TO FUNC-HLD.
- 052700 MOVE ST-NM-HLD TO HDR-ST-NM.
- 052800 4008-EXIT-ST.
- 052900 EXIT.
- 053000 4010-VALIDATE-STDI.
- 053100 MOVE ST-DIST-CD TO DE-CD-8822-DEC.
- 053200 MOVE DI-CD-HLD TO HDR-DIST-CD.
- 053300 MOVE 0003 TO DE-NO-8801-DEC.
- 053400 FIND ANY CODE-DEC.
- 053500 MOVE DB-STATUS TO DB-STAT.
- 053600 IF NOT OK
- 053700 MOVE "UNKNOWN" TO HDR-DIST-NM
- 053800 GO TO 4050-EXIT-STDI.
- 053900 GET CODE-DEC.
- 054000 MOVE DB-STATUS TO DB-STAT.
- 054100 IF NOT OK
- 054200 DISPLAY "ES415PBD 5 DIDN'T GET STDI"
- 054300 DISPLAY "ES415PBD 6 " DB-STAT
- 054400 GO TO 4050-EXIT-STDI.
- 054500 FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
- 054600 MOVE DB-STATUS TO DB-STAT.
- 054700 IF NOT OK
- 054800 MOVE "UNKNOWN" TO HDR-DIST-NM
- 054900 GO TO 4050-EXIT-STDI.
- 055000 GET CODE-EXPL-DECE.
- 055100 MOVE DB-STATUS TO DB-STAT.
- 055200 IF NOT OK
- 055300 DISPLAY "ES415PBD 7 DIDN'T GET DIST"
- 055400 DISPLAY "ES415PBD 8 " DB-STAT
- 055500 GO TO 4050-EXIT-STDI.
- 055600 MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HLD
- 055700 MOVE DIST-NM-HLD TO HDR-DIST-NM.
- 055800 4050-EXIT-STDI.
- 055900 EXIT.
- 056000 4100-CHK-LINE-CNT.
- 056100 IF LINE-CNT > 50
- 056200 PERFORM 4200-PRT-HDNG THRU 4250-HDNG-EXIT
- 056300 GO TO 4150-EXIT-LINE-OVR50.
- 056400 4150-EXIT-LINE-OVR50.
- 056500 EXIT.
- 056600 4200-PRT-HDNG.
- 056700 ADD 1 TO PAGE-CNT.
- 056800 MOVE PAGE-CNT TO HDR-PG.
- 056900 WRITE PRT-REC FROM HDR-1 AFTER ADVANCING PAGE.
- 057000 WRITE PRT-REC FROM HDR-2 AFTER ADVANCING 1 LINES.
- 057100 WRITE PRT-REC FROM HDR-3 AFTER ADVANCING 1 LINES.
- 057200 MOVE 2 TO LINE-CNT.
- 057300 4220-CHK-WHAT-REC.
- 057400 IF HLD-REC-TYPE = "VL"
- 057500 MOVE "VL" TO HDR-REC-TYPE
- 057600 WRITE PRT-REC FROM HDR-4 AFTER ADVANCING 1 LINES
- 057700 WRITE PRT-REC FROM HDR-5-VL AFTER ADVANCING 2 LINES
- 057800 WRITE PRT-REC FROM HDR-6-VL AFTER ADVANCING 1 LINES
- 057900 WRITE PRT-REC FROM HDR-7-VL AFTER ADVANCING 1 LINES
- 058000 WRITE PRT-REC FROM HDR-8-VL AFTER ADVANCING 1 LINES
- 058100 WRITE PRT-REC FROM HDR-9-VL AFTER ADVANCING 1 LINES
- 058200 GO TO 4230-PRT-SPACES.
- 058300 IF HLD-REC-TYPE = "VW"
- 058400 MOVE "VW" TO HDR-REC-TYPE
- 058500 WRITE PRT-REC FROM HDR-4 AFTER ADVANCING 1 LINES
- 058600 WRITE PRT-REC FROM HDR-5-VW AFTER ADVANCING 2 LINES
- 058700 WRITE PRT-REC FROM HDR-6-VW AFTER ADVANCING 1 LINES
- 058800 WRITE PRT-REC FROM HDR-7-VW AFTER ADVANCING 1 LINES
- 058900 WRITE PRT-REC FROM HDR-8-VW AFTER ADVANCING 1 LINES
- 059000 WRITE PRT-REC FROM HDR-9-VW AFTER ADVANCING 1 LINES
- 059100 GO TO 4230-PRT-SPACES.
- 059200 4230-PRT-SPACES.
- 059300 MOVE SPACES TO PRT-REC.
- 059400 WRITE PRT-REC AFTER ADVANCING 1 LINES.
- 059500 ADD 7 TO LINE-CNT.
- 059600 4250-HDNG-EXIT.
- 059700 EXIT.
- 059800 4300-DET-REC-LINE.
- 059900 IF REC-TYPE-3529-VL-S1 = HLD-REC-TYPE
- 060000 PERFORM 4400-PRNT-DET-LINE THRU 4450-EXIT-CHK-REC-TYP
- 060100 GO TO 4320-RET-SORT.
- 060200 IF REC-TYPE-3529-VL-S1 = "99" GO TO 4350-EXIT-DET.
- 060300 MOVE 66 TO LINE-CNT.
- 060400 MOVE 0 TO PAGE-CNT.
- 060500 MOVE REC-TYPE-3529-VL-S1 TO HLD-REC-TYPE.
- 060600 PERFORM 4400-PRNT-DET-LINE THRU 4450-EXIT-CHK-REC-TYP.
- 060700 4320-RET-SORT.
- 060800 RETURN SORT-FILE AT END MOVE 1 TO EOR-SWITCH
- 060900 MOVE "99" TO REC-TYPE-3529-VL-S1.
- 061000 IF EOR-SWITCH = 1 GO TO 4350-EXIT-DET.
- 061100 4350-EXIT-DET.
- 061200 EXIT.
- 061300 4400-PRNT-DET-LINE.
- 061400 PERFORM 4100-CHK-LINE-CNT THRU 4150-EXIT-LINE-OVR50.
- 061500 IF REC-TYPE-3529-VL-S1 = "VL"
- 061600 PERFORM 4500-PRNT-VL THRU 4800-EXIT-PRT-DET
- 061700 GO TO 4450-EXIT-CHK-REC-TYP.
- 061800 IF REC-TYPE-3529-VW-S1 = "VW"
- 061900 PERFORM 4550-PRNT-VW THRU 4800-EXIT-PRT-DET
- 062000 GO TO 4450-EXIT-CHK-REC-TYP.
- 062100 4450-EXIT-CHK-REC-TYP.
- 062200 EXIT.
- 062300 4500-PRNT-VL.
- 062400 MOVE REC-TYPE-3529-VL-S1 TO REC-TYPE-3529-VL-P1.
- 062500 MOVE FMT-NO-3576-VL-S1 TO FMT-NO-3576-VL-P1.
- 062600 MOVE FMT-CD-3579-VL-S1 TO FMT-CD-3579-VL-P1.
- 062700 MOVE ADM-ST-0003-VL-S1 TO ADM-ST-0003-VL-P1.
- 062800 MOVE ADM-DI-0003-VL-S1 TO ADM-DI-0003-VL-P1.
- 062900 MOVE ADM-RA-0003-VL-S1 TO ADM-RA-0003-VL-P1.
- 063000 MOVE ADM-PU-0003-VL-S1 TO ADM-PU-0003-VL-P1.
- 063100 MOVE DATA-DT-6618-VL-S1 TO DATA-DT-6618-VL-P1.
- 063200 MOVE ACT-CD-7350-VL-S1 TO ACT-CD-7350-VL-P1.
- 063300 MOVE LINE-NO-3578-VL-S1 TO LINE-NO-3578-VL-P1.
- 063400 MOVE ALLOT-NUM1-0968-VL-S1 TO ALLOT-NUM1-0968-VL-P1.
- 063500 MOVE ALLOT-NUM2-0968-VL-S1 TO ALLOT-NUM2-0968-VL-P1.
- 063600 MOVE PASTURE-NUM1-3905-VL-S1 TO PASTURE-NUM1-3905-VL-P1.
- 063700 MOVE PASTURE-NUM2-3905-VL-S1 TO PASTURE-NUM2-3905-VL-P1.
- 063800 MOVE ANML-GRZG-CD1-3929-VL-S1 TO ANML-GRZG-CD1-3929-VL-P1.
- 063900 MOVE ANML-GRZG-CD2-3929-VL-S1 TO ANML-GRZG-CD2-3929-VL-P1.
- 064000 MOVE ANML-EST-POP1-3926-VL-S1 TO ANML-EST-POP1-3926-VL-P1.
- 064100 MOVE ANML-EST-POP2-3926-VL-S1 TO ANML-EST-POP2-3926-VL-P1.
- 064200 MOVE USE-MO-DT-FR-3845-VL-S1 (1) TO USE-MO-DT-FR1-3845-VL-P1.
- 064300 MOVE USE-MO-DT-FR-3845-VL-S1 (2) TO USE-MO-DT-FR2-3845-VL-P1.
- 064400 MOVE USE-DD-DT-FR-3845-VL-S1 (1) TO USE-DD-DT-FR1-3845-VL-P1.
- 064500 MOVE USE-DD-DT-FR-3845-VL-S1 (2) TO USE-DD-DT-FR2-3845-VL-P1.
- 064600 MOVE USE-MO-DT-TO-3845-VL-S1 (1) TO USE-MO-DT-TO1-3845-VL-P1.
- 064700 MOVE USE-MO-DT-TO-3845-VL-S1 (2) TO USE-MO-DT-TO2-3845-VL-P1.
- 064800 MOVE USE-DD-DT-TO-3845-VL-S1 (1) TO USE-DD-DT-TO1-3845-VL-P1.
- 064900 MOVE USE-DD-DT-TO-3845-VL-S1 (2) TO USE-DD-DT-TO2-3845-VL-P1.
- 065000 WRITE PRT-REC FROM HDR-10-DET-VL AFTER ADVANCING 2 LINES.
- 065100 ADD 2 TO LINE-CNT.
- 065200 GO TO 4800-EXIT-PRT-DET.
- 065300 4550-PRNT-VW.
- 065400 MOVE REC-TYPE-3529-VW-S1 TO REC-TYPE-3529-VW-P1.
- 065500 MOVE FMT-NO-3576-VW-S1 TO FMT-NO-3576-VW-P1.
- 065600 MOVE FMT-CD-3579-VW-S1 TO FMT-CD-3579-VW-P1.
- 065700 MOVE ADM-ST-0003-VW-S1 TO ADM-ST-0003-VW-P1.
- 065800 MOVE ADM-DI-0003-VW-S1 TO ADM-DI-0003-VW-P1.
- 065900 MOVE ADM-RA-0003-VW-S1 TO ADM-RA-0003-VW-P1.
- 066000 MOVE ADM-PU-0003-VW-S1 TO ADM-PU-0003-VW-P1.
- 066100 MOVE DATA-DT-6618-VW-S1 TO DATA-DT-6618-VW-P1.
- 066200 MOVE ACT-CD-7350-VW-S1 TO ACT-CD-7350-VW-P1.
- 066300 MOVE LINE-NO-3578-VW-S1 TO LINE-NO-3578-VW-P1.
- 066400 MOVE HERD-UNIT-NUM-6598-VW-S1 TO HERD-UNIT-NUM-6598-VW-P1.
- 066500 MOVE ALLOT-NUM-0968-VW-S1 TO ALLOT-NUM-0968-VW-P1.
- 066600 MOVE HERD-UNIT-ALLOT-PCT-3927-VW-S1 TO
- 066700 HERD-UNIT-ALLOT-PCT-3927-VW-P1.
- 066800 MOVE ANML-GRZG-CD-3929-VW-S1 TO ANML-GRZG-CD-3929-VW-P1.
- 066900 MOVE ANML-EST-POP-3926-VW-S1 TO ANML-EST-POP-3926-VW-P1.
- 067000 MOVE USE-MO-DT-FR-3845-VW-S1 TO USE-MO-DT-FR-3845-VW-P1.
- 067100 MOVE USE-DD-DT-FR-3845-VW-S1 TO USE-DD-DT-FR-3845-VW-P1.
- 067200 MOVE USE-MO-DT-TO-3845-VW-S1 TO USE-MO-DT-TO-3845-VW-P1.
- 067300 MOVE USE-DD-DT-TO-3845-VW-S1 TO USE-DD-DT-TO-3845-VW-P1.
- 067400 MOVE SWA-3507-VW-S1 (1) TO SWA1-3507-VW-P1.
- 067500 MOVE SWA-3507-VW-S1 (2) TO SWA2-3507-VW-P1.
- 067600 MOVE SWA-3507-VW-S1 (3) TO SWA3-3507-VW-P1.
- 067700 MOVE SWA-3507-VW-S1 (4) TO SWA4-3507-VW-P1.
- 067800 MOVE SWA-3507-VW-S1 (5) TO SWA5-3507-VW-P1.
- 067900 WRITE PRT-REC FROM HDR-10-DET-VW AFTER ADVANCING 2 LINES.
- 068000 ADD 2 TO LINE-CNT.
- 068100 4800-EXIT-PRT-DET.
- 068200 EXIT.
- 068300 DUMMY-SECTION.
- 068400 5000-DUMMY.
- 068500 EXIT.
- 068600 END-OF-JOB.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES420E.
- 000300* EDIT/UPDATE OF LIVESTOCK (VL) AND
- 000400* WILDLIFE (VW) USE DATA.
- 000500 AUTHOR. FRANK WILEY.
- 000600 DATE-WRITTEN. 20 AUG 79.
- 000700 DATE-COMPILED.
- 000800 ENVIRONMENT DIVISION.
- 000900 CONFIGURATION SECTION.
- 001000 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001100 OBJECT-COMPUTER. LEVEL-66-ASCII, SEQUENCE IS EBCDIC.
- 001200 INPUT-OUTPUT SECTION.
- 001300 FILE-CONTROL.
- 001400 SELECT VL-VW-OUT ASSIGN TO D1
- 001500 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001600 SELECT VL-VW-IN ASSIGN TO I1
- 001700 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001800 SELECT PRINT-FILE ASSIGN TO P1
- 001900 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002000 DATA DIVISION.
- 002100 SUB-SCHEMA SECTION.
- 002200 DB CODVAL2 WITHIN BLMDIC.
- 002300 FILE SECTION.
- 002400 FD VL-VW-IN
- 002500 CODE-SET IS GBCD
- 002600 LABEL RECORDS ARE STANDARD.
- 002700 01 VW-RCD.
- 002800 03 RECORD-FORMAT.
- 002900 05 REC-TYP-W PIC XX.
- 003000 05 FMT-NUM-W PIC X.
- 003100 05 FMT-CD-W PIC X.
- 003200 03 BLM-ADM-IN.
- 003300 05 BLM-ADM-4.
- 003400 07 BLM-ADM-3.
- 003500 09 BLM-ADM-2.
- 003600 11 BLM-ADM-ST-W PIC XX.
- 003700 11 BLM-ADM-DIST-W PIC XX.
- 003800 09 BLM-ADM-RA-W PIC XX.
- 003900 07 BLM-ADM-PLU-W PIC XX.
- 004000 03 DATA-DATE-W PIC X(6).
- 004100 03 ACTN-CD-W PIC X.
- 004200 03 LIN-NUM-W PIC X(4).
- 004300 03 HERD-UNIT-NUM-W PIC X(8).
- 004400 03 ALLOT-NUM-W PIC X(4).
- 004500 03 HERD-UNIT-ALLOT-PCT PIC X(3).
- 004600 03 ANML-GRZG-CD-W PIC XX.
- 004700 03 ANML-EST-POP-W PIC X(5).
- 004800 03 USE-DATES.
- 004900 05 USE-DATES1ST.
- 005000 07 USE-DATES1ST-MON PIC 9(2).
- 005100 88 MON-1-W VALUES 1 THRU 12.
- 005200 07 USE-DATES1ST-DAY PIC 9(2).
- 005300 88 DAY-1-W VALUES 1 THRU 31.
- 005400 05 USE-DATESEND.
- 005500 07 USE-DATESEND-MON PIC 9(2).
- 005600 88 MON-2-W VALUES 1 THRU 12.
- 005700 07 USE-DATESEND-DAY PIC 9(2).
- 005800 88 DAY-2-W VALUES 1 THRU 31.
- 005900 03 SWA-GRP.
- 006000 05 SWA-SET OCCURS 5.
- 006100 07 SWACD-W PIC X.
- 006200 07 SWA-THREE PIC X(3).
- 006300 03 FILLER PIC X(5).
- 006400 01 VL-RCD.
- 006500 03 FILLER PIC X(23).
- 006600 03 HERD-GRP OCCURS 2.
- 006700 05 ALOT-VL PIC XXXX.
- 006800 05 FILLER PIC X(17).
- 006900 03 FILLER PIC X(12).
- 007000 FD PRINT-FILE
- 007100 CODE-SET IS GBCD
- 007200 LABEL RECORDS ARE STANDARD
- 007300 DATA RECORD IS PRINT-RCD.
- 007400 01 PRINT-RCD PIC X(132).
- 007500 FD VL-VW-OUT
- 007600 CODE-SET IS GBCD
- 007700 LABEL RECORD IS STANDARD
- 007800 DATA RECORD VI-OUT-RCD.
- 007900 01 VL-VW-RCD PIC X(78).
- 008000 WORKING-STORAGE SECTION.
- 008100 77 ERROR-SW COMP-4 PIC 9 VALUE ZERO.
- 008200 77 PAGE-NO COMP-4 PIC 9(6) VALUE 0.
- 008300 77 HDR-SW1 COMP-4 PIC 9 VALUE ZERO.
- 008400 77 HDR-SW2 COMP-4 PIC 9 VALUE ZERO.
- 008500 77 LINE-CNT COMP-4 PIC 99 VALUE ZERO.
- 008600 77 HDR-SW3 COMP-4 PIC 9 VALUE ZERO.
- 008700 77 PAGE-SW COMP-4 PIC 9 VALUE 1.
- 008800 77 PROCESS-SW COMP-4 PIC 9 VALUE ZERO.
- 008900 01 BLM-ADM-HOLD.
- 009000 05 ST-HOLD PIC XX.
- 009100 05 DT-HOLD PIC XX.
- 009200 05 RA-HOLD PIC XX.
- 009300 05 PLU-HOLD PIC XX.
- 009400 01 DATE-HOLD.
- 009500 03 YEAR-H PIC 99.
- 009600 03 MON-H PIC 99.
- 009700 03 DAY-H PIC 99.
- 009800 01 MONTH-TABLE PIC X(36) VALUE
- 009900 "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC".
- 010000 01 MONTH-LINE REDEFINES MONTH-TABLE.
- 010100 03 ALPHA-MONTH PIC X(3) OCCURS 12.
- 010200 01 HOLD-AREA.
- 010300 03 FUNC-HOLD.
- 010400 04 STATE-NAME PIC X(10).
- 010500 04 FILLER PIC X(14).
- 010600 03 EXPL-HOLD.
- 010700 04 DIST-NAME PIC X(10).
- 010800 04 FILLER PIC X.
- 010900 04 RA-NAME PIC X(12).
- 011000 04 FILLER PIC X.
- 011100 04 PLU-NAME PIC X(15).
- 011200 04 FILLER PIC X.
- 011300 03 DIST-H PIC XX.
- 011400 COPY DBSTATUS OF TPCOBOLIB.
- 011500 01 HDR-1.
- 011600 03 FILLER PIC X(8) VALUE
- 011700 " PCN ".
- 011800 03 FILLER PIC X(10) VALUE "ES420E ".
- 011900 03 FILLER PIC X(6) VALUE "AS OF ".
- 012000 03 DATE-AS-OF.
- 012100 04 DD PIC 99.
- 012200 04 FILLER PIC X VALUE SPACE.
- 012300 04 MMM PIC XXX.
- 012400 04 FILLER PIC X VALUE SPACE.
- 012500 04 YY PIC 99.
- 012600 03 FILLER PIC X(09) VALUE SPACE.
- 012700 03 FILLER PIC X(48) VALUE
- 012800 "USDI- BUR OF LAND MGT ECOLOGICAL SITE INVENTORY".
- 012900 03 FILLER PIC X(28) VALUE SPACE.
- 013000 03 FILLER PIC X(7) VALUE "PAGE ".
- 013100 03 PAGE-CNT PIC Z,ZZ9.
- 013200 03 FILLER PIC X(02) VALUE SPACE.
- 013300 01 HDR-2.
- 013400 03 FILLER PIC X(17) VALUE SPACE.
- 013500 03 FILLER PIC X(8) VALUE "STATE ".
- 013600 03 ST-HDR PIC X(15).
- 013700 03 FILLER PIC X(16) VALUE SPACE.
- 013800 03 FILLER PIC X(7) VALUE "DIST ".
- 013900 03 DIST-HDR PIC X(15).
- 014000 03 FILLER PIC X(15) VALUE SPACE.
- 014100 03 VL-VW-TYPE PIC XX VALUE "VL".
- 014200 03 FILLER PIC X(20) VALUE
- 014300 " EDIT ERROR LISTING".
- 014400 03 FILLER PIC X(17) VALUE SPACE.
- 014500 01 HDR-3.
- 014600 03 FILLER PIC X(40) VALUE
- 014700 " REC TYP ST ".
- 014800 03 FILLER PIC X(40) VALUE
- 014900 " DIST RA ".
- 015000 03 FILLER PIC X(40) VALUE
- 015100 "PLU DATE ACTN ".
- 015200 03 FILLER PIC X(12) VALUE SPACE.
- 015300 01 HDR-4.
- 015400 03 FILLER PIC X(17) VALUE SPACE.
- 015500 03 FILLER PIC X(43) VALUE
- 015600 "1-4 5-6 7-8 ".
- 015700 03 FILLER PIC X(41) VALUE
- 015800 " 9-10 11-12 13-18".
- 015900 03 FILLER PIC X(31) VALUE
- 016000 " 19 ".
- 016100 01 HDR-5.
- 016200 03 FILLER PIC X(17) VALUE SPACE.
- 016300 03 FILLER PIC X(43) VALUE
- 016400 "XXXX XX XX ".
- 016500 03 FILLER PIC X(43) VALUE
- 016600 " XX XX XXXXXX ".
- 016700 03 FILLER PIC X(29) VALUE
- 016800 " X ".
- 016900 01 HDR-6L.
- 017000 03 FILLER PIC X(40) VALUE
- 017100 " LIN NUM ALLOT PASTURE ANML SP ".
- 017200 03 FILLER PIC X(40) VALUE
- 017300 "AUTH/LSTK FROM DATE TO DATE ALLOT P".
- 017400 03 FILLER PIC X(40) VALUE
- 017500 "ASTURE ANML SP AUTH/LSTK FROM DATE ".
- 017600 03 FILLER PIC X(12) VALUE
- 017700 " TO DATE ".
- 017800 01 HDR-7L.
- 017900 03 FILLER PIC X(40) VALUE
- 018000 " 20-23 24-27 28-29 30-31 ".
- 018100 03 FILLER PIC X(40) VALUE
- 018200 " 32-36 37-40 41-44 45-48 ".
- 018300 03 FILLER PIC X(40) VALUE
- 018400 "49-50 51-52 53-57 58-61 ".
- 018500 03 FILLER PIC X(12) VALUE
- 018600 " 62-65 ".
- 018700 01 HDR-8L.
- 018800 03 FILLER PIC X(40) VALUE
- 018900 " XXXX XXXX XX XX ".
- 019000 03 FILLER PIC X(40) VALUE
- 019100 " XXXXX XX/XX XX/XX XXXX ".
- 019200 03 FILLER PIC X(40) VALUE
- 019300 " XX XX XXXXX XX/XX ".
- 019400 03 FILLER PIC X(12) VALUE
- 019500 " XX/XX ".
- 019600 01 HDR-9W.
- 019700 03 FILLER PIC X(40) VALUE
- 019800 " LIN NUM HRD NO ALLOT % HRD ".
- 019900 03 FILLER PIC X(45) VALUE
- 020000 " ANML SP EST NUM ANML FROM DATE TO DATE".
- 020100 03 FILLER PIC X(39) VALUE
- 020200 " SWA SWA SWA SWA SWA ".
- 020300 03 FILLER PIC X(8) VALUE SPACE.
- 020400 01 HDR-10W.
- 020500 03 FILLER PIC X(40) VALUE
- 020600 " 20-23 24-31 32-35 36-38 ".
- 020700 03 FILLER PIC X(45) VALUE
- 020800 " 39-40 41-45 46-49 50-53 ".
- 020900 03 FILLER PIC X(39) VALUE
- 021000 " 54-57 58-61 62-65 66-69 70-73 ".
- 021100 03 FILLER PIC X(8) VALUE SPACE.
- 021200 01 HDR-11W.
- 021300 03 FILLER PIC X(40) VALUE
- 021400 " XXXX XXXXXXXX XXXX XXX ".
- 021500 03 FILLER PIC X(45) VALUE
- 021600 " XX XXXXX XX/XX XX/XX ".
- 021700 03 FILLER PIC X(39) VALUE
- 021800 " XXXX XXXX XXXX XXXX XXXX ".
- 021900 03 FILLER PIC X(8) VALUE SPACE.
- 022000 01 PRINT-1LW.
- 022100 03 FILLER PIC X(17) VALUE SPACE.
- 022200 03 REC-TYP-P PIC X(4).
- 022300 03 FILLER PIC X(13) VALUE SPACE.
- 022400 03 BLM-ADM-ST PIC XX.
- 022500 03 FILLER PIC X(14) VALUE SPACE.
- 022600 03 BLM-ADM-DIST PIC XX.
- 022700 03 FILLER PIC X(12) VALUE SPACE.
- 022800 03 BLM-ADM-RA PIC XX.
- 022900 03 FILLER PIC X(15) VALUE SPACE.
- 023000 03 BLM-ADM-PLU PIC XX.
- 023100 03 FILLER PIC X(13) VALUE SPACE.
- 023200 03 DATA-DATE-P PIC X(6).
- 023300 03 FILLER PIC X(13) VALUE SPACE.
- 023400 03 ACTN-CD-P PIC X.
- 023500 03 FILLER PIC X(16) VALUE SPACE.
- 023600 01 PRINT-2LW.
- 023700 03 FILLER PIC X(17) VALUE SPACE.
- 023800 03 ASTER-1 PIC X(4).
- 023900 03 FILLER PIC X(13) VALUE SPACE.
- 024000 03 ASTER-2 PIC XX.
- 024100 03 FILLER PIC X(14) VALUE SPACE.
- 024200 03 ASTER-3 PIC XX.
- 024300 03 FILLER PIC X(12) VALUE SPACE.
- 024400 03 ASTER-4 PIC XX.
- 024500 03 FILLER PIC X(15) VALUE SPACE.
- 024600 03 ASTER-5 PIC XX.
- 024700 03 FILLER PIC X(49) VALUE SPACE.
- 024800 01 PRINT-3L.
- 024900 03 FILLER PIC X(5) VALUE SPACE.
- 025000 03 LIN-NUM-P1 PIC X(4).
- 025100 03 FILLER PIC X(4) VALUE SPACE.
- 025200 03 ALLOT-NUM-P1 PIC X(4).
- 025300 03 FILLER PIC X(6) VALUE SPACE.
- 025400 03 PASTURE-NUM-P1 PIC XX.
- 025500 03 FILLER PIC X(8) VALUE SPACE.
- 025600 03 ANML-GRZG-CD-P1 PIC XX.
- 025700 03 FILLER PIC X(7) VALUE SPACE.
- 025800 03 ANML-EST-POP-P1 PIC X(5).
- 025900 03 FILLER PIC X(6) VALUE SPACE.
- 026000 03 USE-DATE-FROM.
- 026100 05 F-MM-1 PIC XX.
- 026200 05 FILLER PIC X VALUE SPACE.
- 026300 05 F-DD-1 PIC XX.
- 026400 03 FILLER PIC X(5) VALUE SPACE.
- 026500 03 USE-DATE-TO.
- 026600 05 T-MM-1 PIC XX.
- 026700 05 FILLER PIC X VALUE SPACE.
- 026800 05 T-DD-1 PIC XX.
- 026900 03 FILLER PIC X(4) VALUE SPACE.
- 027000 03 ALLOT-NUM-P2 PIC X(4).
- 027100 03 FILLER PIC X(6) VALUE SPACE.
- 027200 03 PASTURE-NUM-P2 PIC XX.
- 027300 03 FILLER PIC X(8) VALUE SPACE.
- 027400 03 ANML-GRZG-CD-P2 PIC XX.
- 027500 03 FILLER PIC X(7) VALUE SPACE.
- 027600 03 ANML-EST-POP-P2 PIC X(5).
- 027700 03 FILLER PIC X(6) VALUE SPACE.
- 027800 03 USE-DATE-FROM-1.
- 027900 05 F-MM-2 PIC XX.
- 028000 05 FILLER PIC X VALUE SPACE.
- 028100 05 F-DD-2 PIC XX.
- 028200 03 FILLER PIC X(5) VALUE SPACE.
- 028300 03 USE-DATE-TO-1.
- 028400 05 T-MM-2 PIC XX.
- 028500 05 FILLER PIC X VALUE SPACE.
- 028600 05 T-DD-2 PIC XX.
- 028700 03 FILLER PIC X(5) VALUE SPACE.
- 028800 01 PRINT-4L.
- 028900 03 FILLER PIC X(13) VALUE SPACE.
- 029000 03 ASTER-11 PIC X(4).
- 029100 03 FILLER PIC X(6) VALUE SPACE.
- 029200 03 ASTER-12 PIC X(2).
- 029300 03 FILLER PIC X(8) VALUE SPACE.
- 029400 03 ASTER-13 PIC X(2).
- 029500 03 FILLER PIC X(7) VALUE SPACE.
- 029600 03 ASTER-14 PIC X(5).
- 029700 03 FILLER PIC X(6) VALUE SPACE.
- 029800 03 ASTER-15 PIC X(5).
- 029900 03 FILLER PIC X(5) VALUE SPACE.
- 030000 03 ASTER-16 PIC X(5).
- 030100 03 FILLER PIC X(4) VALUE SPACE.
- 030200 03 ASTER-17 PIC X(4).
- 030300 03 FILLER PIC X(6) VALUE SPACE.
- 030400 03 ASTER-18 PIC X(2).
- 030500 03 FILLER PIC X(8) VALUE SPACE.
- 030600 03 ASTER-19 PIC X(2).
- 030700 03 FILLER PIC X(7) VALUE SPACE.
- 030800 03 ASTER-20 PIC X(5).
- 030900 03 FILLER PIC X(6) VALUE SPACE.
- 031000 03 ASTER-21 PIC X(5).
- 031100 03 FILLER PIC X(5) VALUE SPACE.
- 031200 03 ASTER-22 PIC X(5).
- 031300 03 FILLER PIC X(5) VALUE SPACE.
- 031400 01 PRINT-5W.
- 031500 03 FILLER PIC X(5) VALUE SPACE.
- 031600 03 LIN-NUM-P3 PIC X(4).
- 031700 03 FILLER PIC X(4) VALUE SPACE.
- 031800 03 HERD-NO-P3 PIC X(8).
- 031900 03 FILLER PIC X(3) VALUE SPACE.
- 032000 03 ALLOT-NUM-P3 PIC X(4).
- 032100 03 FILLER PIC X(5) VALUE SPACE.
- 032200 03 PCT-HERD-P3 PIC X(3).
- 032300 03 FILLER PIC X(8) VALUE SPACE.
- 032400 03 ANML-GRZG-CD-P3 PIC XX.
- 032500 03 FILLER PIC X(9) VALUE SPACE.
- 032600 03 ANML-EST-POP-P3 PIC X(5).
- 032700 03 FILLER PIC X(9) VALUE SPACE.
- 032800 03 USE-DATE-FROM5.
- 032900 05 F-MM-3 PIC XX.
- 033000 05 FILLER PIC X VALUE SPACE.
- 033100 05 F-DD-3 PIC XX.
- 033200 03 FILLER PIC X(5) VALUE SPACE.
- 033300 03 USE-DATE-TO5.
- 033400 05 T-MM-4 PIC XX.
- 033500 05 FILLER PIC X VALUE SPACE.
- 033600 05 T-DD-4 PIC XX.
- 033700 03 FILLER PIC X(4) VALUE SPACE.
- 033800 03 SWA-1P PIC X(4).
- 033900 03 FILLER PIC X(3) VALUE SPACE.
- 034000 03 SWA-2P PIC X(4).
- 034100 03 FILLER PIC X(3) VALUE SPACE.
- 034200 03 SWA-3P PIC X(4).
- 034300 03 FILLER PIC X(3) VALUE SPACE.
- 034400 03 SWA-4P PIC X(4).
- 034500 03 FILLER PIC X(3) VALUE SPACE.
- 034600 03 SWA-5P PIC X(4).
- 034700 03 FILLER PIC X(12) VALUE SPACE.
- 034800 01 PRINT-6W.
- 034900 03 FILLER PIC X(13) VALUE SPACE.
- 035000 03 ASTER-24 PIC X(8).
- 035100 03 FILLER PIC X(3) VALUE SPACE.
- 035200 03 ASTER-25 PIC X(4).
- 035300 03 FILLER PIC X(5) VALUE SPACE.
- 035400 03 ASTER-26 PIC X(3).
- 035500 03 FILLER PIC X(8) VALUE SPACE.
- 035600 03 ASTER-27 PIC X(2).
- 035700 03 FILLER PIC X(9) VALUE SPACE.
- 035800 03 ASTER-28 PIC X(5).
- 035900 03 FILLER PIC X(9) VALUE SPACE.
- 036000 03 ASTER-29 PIC X(5).
- 036100 03 FILLER PIC X(5) VALUE SPACE.
- 036200 03 ASTER-30 PIC X(5).
- 036300 03 FILLER PIC X(4) VALUE SPACE.
- 036400 03 ASTER-31 PIC X(4).
- 036500 03 FILLER PIC X(3) VALUE SPACE.
- 036600 03 ASTER-32 PIC X(4).
- 036700 03 FILLER PIC X(3) VALUE SPACE.
- 036800 03 ASTER-33 PIC X(4).
- 036900 03 FILLER PIC X(3) VALUE SPACE.
- 037000 03 ASTER-34 PIC X(4).
- 037100 03 FILLER PIC X(3) VALUE SPACE.
- 037200 03 ASTER-35 PIC X(4).
- 037300 03 FILLER PIC X(12) VALUE SPACE.
- 037400 01 INFO-LIN-1.
- 037500 03 FILLER PIC X(24) VALUE SPACE.
- 037600 03 FILLER PIC X(38) VALUE
- 037700 "IF ERROR CORRECTION IS IN COMMON DATA ".
- 037800 03 FILLER PIC X(46) VALUE
- 037900 "(1-12), KEY ALL RECORDS WITH SAME COMMON DATA.".
- 038000 03 FILLER PIC X(24) VALUE SPACE.
- 038100 01 INFO-LIN-2.
- 038200 03 FILLER PIC X(24) VALUE SPACE.
- 038300 03 FILLER PIC X(42) VALUE
- 038400 "IF ERROR CORRECTION IS IN FIELD POSITIONS ".
- 038500 03 FILLER PIC X(45) VALUE
- 038600 "(24-73), KEY (1-23) AND RED CORRECTED FIELDS.".
- 038700 03 FILLER PIC X(21) VALUE SPACE.
- 038800 01 HERD-GRP-WORK.
- 038900 03 ALLOT-NUM-L PIC 9(4).
- 039000 03 ALLOT-NUM-L-A REDEFINES ALLOT-NUM-L PIC X(4).
- 039100 03 PASTURE-NUM-L PIC 9(2).
- 039200 03 PASTURE-NUM-L-A REDEFINES PASTURE-NUM-L PIC X(2).
- 039300 03 ANML-GRZG-CD-L PIC X(2).
- 039400 03 ANML-EST-POP-L PIC 9(5).
- 039500 03 USE-DATES-L.
- 039600 07 USE-DATES-L-1ST.
- 039700 09 USE-DATES-L-1ST-MON PIC 9(2).
- 039800 88 MON-1-L VALUES 1 THRU 12.
- 039900 09 USE-DATES-L-1ST-DAY PIC 9(2).
- 040000 88 DAY-1-L VALUES 1 THRU 31.
- 040100 07 USE-DATES-L-END.
- 040200 09 USE-DATES-L-END-MON PIC 9(2).
- 040300 88 MON-2-L VALUES 1 THRU 12.
- 040400 09 USE-DATES-L-END-DAY PIC 9(2).
- 040500 88 DAY-2-L VALUES 1 THRU 31.
- 040600 PROCEDURE DIVISION.
- 040700 005-START SECTION.
- 040800 010-OPEN-FILES.
- 040900 READY DIC-DE.
- 041000 OPEN INPUT VL-VW-IN.
- 041100 OPEN OUTPUT PRINT-FILE, VL-VW-OUT.
- 041200 MOVE SPACE TO PRINT-RCD.
- 041300 WRITE PRINT-RCD BEFORE ADVANCING PAGE.
- 041400 ACCEPT DATE-HOLD FROM DATE.
- 041500 MOVE YEAR-H TO YY.
- 041600 MOVE DAY-H TO DD.
- 041700 MOVE ALPHA-MONTH (MON-H) TO MMM.
- 041800 MOVE PAGE-NO TO PAGE-CNT.
- 041900 MOVE SPACE TO PRINT-2LW, PRINT-4L, PRINT-6W.
- 042000 015-READ.
- 042100 READ VL-VW-IN AT END
- 042200 GO TO 9090-END.
- 042300 020-HOLD.
- 042400 MOVE BLM-ADM-IN TO BLM-ADM-HOLD.
- 042500 025-EDIT-RCD-TYPE.
- 042600 IF RECORD-FORMAT = "VL1D"
- 042700 GO TO 035-EDIT-ST.
- 042800 IF REC-TYP-W = "VL"
- 042900 GO TO 030-EDIT-VL.
- 043000 GO TO 700-EDIT-VW.
- 043100 030-EDIT-VL.
- 043200 MOVE 1 TO HDR-SW1.
- 043300 MOVE ALL "*" TO ASTER-1.
- 043400 035-EDIT-ST.
- 043500 MOVE BLM-ADM-ST-W TO DE-CD-8822-DEC.
- 043600 MOVE 0003 TO DE-NO-8801-DEC.
- 043700 FIND ANY CODE-DEC.
- 043800 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 043900 IF OK
- 044000 GET CODE-DEC
- 044100 MOVE DE-CD-NAM-8823-DEC TO FUNC-HOLD
- 044200 MOVE STATE-NAME TO ST-HDR
- 044300 GO TO 040-EDIT-DT.
- 044400 MOVE 1 TO HDR-SW1.
- 044500 MOVE "UNKNOWN" TO ST-HDR, DIST-HDR.
- 044600 MOVE ALL "*" TO ASTER-2, ASTER-3, ASTER-4, ASTER-5.
- 044700 GO TO 057-EXIT-BLM.
- 044800 040-EDIT-DT.
- 044900 MOVE BLM-ADM-2 TO DE-CD-8822-DEC.
- 045000 MOVE 0003 TO DE-NO-8801-DEC.
- 045100 FIND ANY CODE-DEC.
- 045200 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 045300 IF OK
- 045400 GET CODE-DEC
- 045500 GO TO 045-FIND-DT.
- 045600 MOVE "UNKNOWN" TO DIST-HDR.
- 045700 MOVE 1 TO HDR-SW1.
- 045800 MOVE ALL "*" TO ASTER-3, ASTER-4, ASTER-5.
- 045900 GO TO 057-EXIT-BLM.
- 046000 045-FIND-DT.
- 046100 FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
- 046200 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 046300 IF OK
- 046400 GET CODE-EXPL-DECE
- 046500 MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HOLD
- 046600 MOVE DIST-NAME TO DIST-HDR
- 046700 GO TO 050-EDIT-RA.
- 046800 MOVE "UNKNOWN" TO DIST-HDR.
- 046900 050-EDIT-RA.
- 047000 MOVE BLM-ADM-3 TO DE-CD-8822-DEC.
- 047100 MOVE 0003 TO DE-NO-8801-DEC.
- 047200 FIND ANY CODE-DEC.
- 047300 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 047400 IF OK
- 047500 GO TO 055-EDIT-PLU.
- 047600 MOVE 1 TO HDR-SW1.
- 047700 MOVE ALL "*" TO ASTER-4, ASTER-5.
- 047800 GO TO 057-EXIT-BLM.
- 047900 055-EDIT-PLU.
- 048000 MOVE BLM-ADM-4 TO DE-CD-8822-DEC.
- 048100 MOVE 0003 TO DE-NO-8801-DEC.
- 048200 FIND ANY CODE-DEC.
- 048300 MOVE DB-STATUS TO DATA-BASE-STATUS.
- 048400 IF OK
- 048500 GO TO 057-EXIT-BLM.
- 048600 MOVE ALL "*" TO ASTER-5.
- 048700 MOVE 1 TO HDR-SW1.
- 048800 057-EXIT-BLM.
- 048900 EXIT.
- 049000 058-MOVE-HERD.
- 049100 MOVE HERD-GRP (1) TO HERD-GRP-WORK.
- 049200 IF ALLOT-NUM-L-A = SPACE GO TO 095-NEXT-SET.
- 049300 060-EDIT-ALLOTMENT.
- 049400 IF ALLOT-NUM-L NUMERIC GO TO 065-PASTURE.
- 049500 MOVE 1 TO HDR-SW2.
- 049600 PERFORM 081-ASTERISK.
- 049700 065-PASTURE.
- 049800 IF PASTURE-NUM-L-A = SPACE
- 049900 GO TO 070-ANML-SP.
- 050000 IF PASTURE-NUM-L = ZERO
- 050100 GO TO 070-ANML-SP.
- 050200 IF PASTURE-NUM-L NUMERIC AND PASTURE-NUM-L
- 050300 GREATER THAN ZERO
- 050400 GO TO 070-ANML-SP.
- 050500 MOVE 1 TO HDR-SW2.
- 050600 PERFORM 082-ASTERISK.
- 050700 070-ANML-SP.
- 050800* MOVE ANML-GRZG-CD-L TO DE-CD-8822-DEC.
- 050900* MOVE 3929 TO DE-NO-8801-DEC.
- 051000* FIND ANY CODE-DEC.
- 051100* MOVE DB-STATUS TO DATA-BASE-STATUS.
- 051200* IF OK
- 051300* GO TO 075-ANML-EST-POP.
- 051400* MOVE 1 TO HDR-SW2.
- 051500* PERFORM 083-ASTERISK.
- 051600 075-ANML-EST-POP.
- 051700 IF ANML-EST-POP-L NUMERIC AND ANML-EST-POP-L > ZERO
- 051800 GO TO 080-USE-DATES.
- 051900 MOVE 1 TO HDR-SW2.
- 052000 PERFORM 084-ASTERISK.
- 052100 080-USE-DATES.
- 052200 IF MON-1-L NEXT SENTENCE ELSE
- 052300 MOVE 1 TO HDR-SW2
- 052400 PERFORM 085-ASTERISK.
- 052500 IF DAY-1-L NEXT SENTENCE ELSE
- 052600 MOVE 1 TO HDR-SW2
- 052700 PERFORM 085-ASTERISK.
- 052800 IF MON-2-L NEXT SENTENCE ELSE
- 052900 MOVE 1 TO HDR-SW2
- 053000 PERFORM 086-ASTERISK.
- 053100 IF DAY-2-L NEXT SENTENCE ELSE
- 053200 MOVE 1 TO HDR-SW2
- 053300 PERFORM 086-ASTERISK.
- 053400 IF (USE-DATES-L-1ST-MON = 04 OR 06 OR 09 OR 11)
- 053500 AND (USE-DATES-L-1ST-DAY = 31)
- 053600 MOVE 1 TO HDR-SW2
- 053700 PERFORM 085-ASTERISK.
- 053800 IF (USE-DATES-L-END-MON = 04 OR 06 OR 09 OR 11)
- 053900 AND (USE-DATES-L-END-DAY = 31)
- 054000 MOVE 1 TO HDR-SW2
- 054100 PERFORM 086-ASTERISK.
- 054200 IF (USE-DATES-L-1ST-MON = 02)
- 054300 AND (USE-DATES-L-1ST-DAY > 28)
- 054400 MOVE 1 TO HDR-SW2
- 054500 PERFORM 085-ASTERISK.
- 054600 IF (USE-DATES-L-END-MON = 02)
- 054700 AND (USE-DATES-L-END-DAY > 28)
- 054800 MOVE 1 TO HDR-SW2
- 054900 PERFORM 086-ASTERISK.
- 055000 GO TO 090-EXIT-EDIT.
- 055100 081-ASTERISK.
- 055200 IF HDR-SW3 = ZERO
- 055300 MOVE ALL "*" TO ASTER-11
- 055400 ELSE MOVE ALL "*" TO ASTER-17.
- 055500 082-ASTERISK.
- 055600 IF HDR-SW3 = ZERO
- 055700 MOVE ALL "*" TO ASTER-12
- 055800 ELSE MOVE ALL "*" TO ASTER-18.
- 055900 083-ASTERISK.
- 056000 IF HDR-SW3 = ZERO
- 056100 MOVE ALL "*" TO ASTER-13
- 056200 ELSE MOVE ALL "*" TO ASTER-19.
- 056300 084-ASTERISK.
- 056400 IF HDR-SW3 = ZERO
- 056500 MOVE ALL "*" TO ASTER-14
- 056600 ELSE MOVE ALL "*" TO ASTER-20.
- 056700 085-ASTERISK.
- 056800 IF HDR-SW3 = ZERO
- 056900 MOVE ALL "*" TO ASTER-15
- 057000 ELSE MOVE ALL "*" TO ASTER-21.
- 057100 086-ASTERISK.
- 057200 IF HDR-SW3 = ZERO
- 057300 MOVE ALL "*" TO ASTER-16
- 057400 ELSE MOVE ALL "*" TO ASTER-22.
- 057500 090-EXIT-EDIT.
- 057600 EXIT.
- 057700 095-NEXT-SET.
- 057800 MOVE HERD-GRP (2) TO HERD-GRP-WORK.
- 057900 IF ALLOT-NUM-L-A = SPACE
- 058000 GO TO 100-SWITCH-CHECK.
- 058100 MOVE 1 TO HDR-SW3.
- 058200 PERFORM 060-EDIT-ALLOTMENT THRU 090-EXIT-EDIT.
- 058300 MOVE ZERO TO HDR-SW3.
- 058400 100-SWITCH-CHECK.
- 058500 IF HDR-SW1 = ZERO
- 058600 GO TO 115-HDR-SW2.
- 058700 IF PAGE-SW = 1
- 058800 PERFORM 415-HDR-ST-DIST
- 058900 MOVE ZERO TO PAGE-SW.
- 059000 PERFORM 420-HDRS-CNTL.
- 059100 105-WRITE-CONTROL.
- 059200 PERFORM 430-MOVE-CTL-DATA.
- 059300 MOVE PRINT-1LW TO PRINT-RCD.
- 059400 WRITE PRINT-RCD BEFORE 1.
- 059500 MOVE PRINT-2LW TO PRINT-RCD.
- 059600 WRITE PRINT-RCD BEFORE 2.
- 059700 ADD 3 TO LINE-CNT.
- 059800 MOVE 1 TO ERROR-SW.
- 059900 110-WRITE-DATA.
- 060000 PERFORM 425-HDRS-DATA.
- 060100 PERFORM 435-MOVE-DATA THRU 450-EXIT-MOVE.
- 060200 MOVE PRINT-3L TO PRINT-RCD.
- 060300 WRITE PRINT-RCD BEFORE 1.
- 060400 IF HDR-SW2 = ZERO
- 060500 MOVE SPACE TO PRINT-RCD
- 060600 ELSE
- 060700 MOVE PRINT-4L TO PRINT-RCD
- 060800 MOVE 1 TO ERROR-SW.
- 060900 WRITE PRINT-RCD BEFORE 2.
- 061000 ADD 3 TO LINE-CNT.
- 061100 112-DUMMY.
- 061200 GO TO 120-NEW-RCD.
- 061300 115-HDR-SW2.
- 061400 IF HDR-SW2 = ZERO
- 061500 GO TO 120-NEW-RCD.
- 061600 IF PAGE-SW = ZERO
- 061700 PERFORM 110-WRITE-DATA
- 061800 GO TO 120-NEW-RCD.
- 061900 PERFORM 415-HDR-ST-DIST THRU 420-HDRS-CNTL.
- 062000 PERFORM 430-MOVE-CTL-DATA.
- 062100 MOVE PRINT-1LW TO PRINT-RCD.
- 062200 WRITE PRINT-RCD BEFORE 1.
- 062300 ADD 1 TO LINE-CNT.
- 062400 MOVE ZERO TO PAGE-SW.
- 062500 PERFORM 110-WRITE-DATA.
- 062600 120-NEW-RCD.
- 062700 MOVE HERD-GRP (1) TO HERD-GRP-WORK.
- 062800 IF (PASTURE-NUM-L-A = SPACE AND ALLOT-NUM-L-A NOT = SPACE)
- 062900 MOVE ZERO TO PASTURE-NUM-L
- 063000 MOVE HERD-GRP-WORK TO HERD-GRP (1).
- 063100 MOVE HERD-GRP (2) TO HERD-GRP-WORK.
- 063200 IF (PASTURE-NUM-L-A = SPACE AND ALLOT-NUM-L-A NOT = SPACE)
- 063300 MOVE ZERO TO PASTURE-NUM-L
- 063400 MOVE HERD-GRP-WORK TO HERD-GRP (2).
- 063500 IF (ALOT-VL (1) = SPACE) AND
- 063600 (ALOT-VL (2) = SPACE)
- 063700 GO TO 130-READ-NEXT.
- 063800 MOVE VL-RCD TO VL-VW-RCD.
- 063900 WRITE VL-VW-RCD.
- 064000 GO TO 130-READ-NEXT.
- 064100 125-ZERO-OUT.
- 064200 MOVE ZERO TO HDR-SW1, HDR-SW2, HDR-SW3.
- 064300 MOVE SPACE TO PRINT-2LW, PRINT-4L, PRINT-6W.
- 064400 130-READ-NEXT.
- 064500 READ VL-VW-IN AT END
- 064600 GO TO 9090-END.
- 064700 IF RECORD-FORMAT = "VL1D"
- 064800 GO TO 135-ST-CHECK.
- 064900 IF REC-TYP-W = "VL"
- 065000 PERFORM 030-EDIT-VL
- 065100 GO TO 135-ST-CHECK.
- 065200 GO TO 700-EDIT-VW.
- 065300 135-ST-CHECK.
- 065400 IF BLM-ADM-ST-W = ST-HOLD
- 065500 GO TO 150-DIST-CHECK.
- 065600 PERFORM 145-NEW-PAGE.
- 065700 GO TO 035-EDIT-ST.
- 065800 145-NEW-PAGE.
- 065900 MOVE 0 TO PAGE-NO.
- 066000 MOVE 1 TO PAGE-SW.
- 066100 PERFORM 125-ZERO-OUT.
- 066200 PERFORM 020-HOLD.
- 066300 150-DIST-CHECK.
- 066400 IF BLM-ADM-DIST-W = DT-HOLD
- 066500 GO TO 155-RA-CHECK.
- 066600 PERFORM 145-NEW-PAGE.
- 066700 GO TO 035-EDIT-ST.
- 066800 155-RA-CHECK.
- 066900 IF BLM-ADM-RA-W = RA-HOLD
- 067000 GO TO 160-PLU-CHECK.
- 067100 MOVE 1 TO PAGE-SW.
- 067200 PERFORM 125-ZERO-OUT.
- 067300 PERFORM 020-HOLD.
- 067400 GO TO 035-EDIT-ST.
- 067500 160-PLU-CHECK.
- 067600 IF BLM-ADM-PLU-W = PLU-HOLD
- 067700 GO TO 165-EQUAL-CONTROL.
- 067800 MOVE 1 TO PAGE-SW.
- 067900 PERFORM 125-ZERO-OUT.
- 068000 PERFORM 020-HOLD.
- 068100 GO TO 035-EDIT-ST.
- 068200 165-EQUAL-CONTROL.
- 068300 MOVE SPACE TO PRINT-4L.
- 068400 MOVE ZERO TO HDR-SW2.
- 068500 MOVE HERD-GRP (1) TO HERD-GRP-WORK.
- 068600 IF ALLOT-NUM-L-A NOT = SPACE
- 068700 PERFORM 060-EDIT-ALLOTMENT THRU 090-EXIT-EDIT.
- 068800 MOVE HERD-GRP (2) TO HERD-GRP-WORK.
- 068900 MOVE 1 TO HDR-SW3.
- 069000 IF ALLOT-NUM-L-A = SPACE NEXT SENTENCE ELSE
- 069100 PERFORM 060-EDIT-ALLOTMENT THRU 090-EXIT-EDIT.
- 069200 MOVE ZERO TO HDR-SW3.
- 069300 IF HDR-SW1 NOT = ZERO
- 069400 GO TO 166-PAGE.
- 069500 IF HDR-SW2 = ZERO
- 069600 GO TO 120-NEW-RCD.
- 069700 166-PAGE.
- 069800 IF PAGE-SW = ZERO
- 069900 GO TO 170-CONTINUE.
- 070000 MOVE ZERO TO PAGE-SW.
- 070100 PERFORM 415-HDR-ST-DIST THRU 420-HDRS-CNTL.
- 070200 PERFORM 430-MOVE-CTL-DATA.
- 070300 MOVE PRINT-1LW TO PRINT-RCD.
- 070400 WRITE PRINT-RCD BEFORE 1.
- 070500 IF HDR-SW1 = 1
- 070600 MOVE PRINT-2LW TO PRINT-RCD
- 070700 MOVE 1 TO ERROR-SW
- 070800 ELSE
- 070900 MOVE SPACE TO PRINT-RCD.
- 071000 WRITE PRINT-RCD BEFORE 2.
- 071100 ADD 3 TO LINE-CNT.
- 071200 PERFORM 425-HDRS-DATA.
- 071300 170-CONTINUE.
- 071400 PERFORM 435-MOVE-DATA THRU 450-EXIT-MOVE.
- 071500 MOVE PRINT-3L TO PRINT-RCD.
- 071600 MOVE 1 TO ERROR-SW.
- 071700 WRITE PRINT-RCD BEFORE 1.
- 071800 IF HDR-SW2 = ZERO
- 071900 MOVE SPACE TO PRINT-RCD
- 072000 ELSE
- 072100 MOVE PRINT-4L TO PRINT-RCD
- 072200 MOVE 1 TO ERROR-SW.
- 072300 WRITE PRINT-RCD BEFORE 2.
- 072400 ADD 3 TO LINE-CNT.
- 072500 IF LINE-CNT GREATER THAN 54
- 072600 MOVE 1 TO PAGE-SW.
- 072700 GO TO 120-NEW-RCD.
- 072800 400-LINE-CNT.
- 072900 MOVE SPACE TO PRINT-RCD.
- 073000 WRITE PRINT-RCD BEFORE PAGE.
- 073100 MOVE ZERO TO LINE-CNT.
- 073200 MOVE 0 TO PAGE-SW.
- 073300 ADD 1 TO PAGE-NO.
- 073400 MOVE PAGE-NO TO PAGE-CNT.
- 073500 415-HDR-ST-DIST.
- 073600 PERFORM 400-LINE-CNT.
- 073700 MOVE HDR-1 TO PRINT-RCD.
- 073800 WRITE PRINT-RCD BEFORE 2.
- 073900 MOVE HDR-2 TO PRINT-RCD.
- 074000 WRITE PRINT-RCD BEFORE 2.
- 074100 MOVE INFO-LIN-1 TO PRINT-RCD.
- 074200 WRITE PRINT-RCD BEFORE 1.
- 074300 MOVE INFO-LIN-2 TO PRINT-RCD.
- 074400 WRITE PRINT-RCD BEFORE 2.
- 074500 ADD 7 TO LINE-CNT.
- 074600 420-HDRS-CNTL.
- 074700 MOVE HDR-3 TO PRINT-RCD.
- 074800 WRITE PRINT-RCD BEFORE 1.
- 074900 MOVE HDR-4 TO PRINT-RCD.
- 075000 WRITE PRINT-RCD BEFORE 1.
- 075100 MOVE HDR-5 TO PRINT-RCD.
- 075200 WRITE PRINT-RCD BEFORE 2.
- 075300 ADD 4 TO LINE-CNT.
- 075400 425-HDRS-DATA.
- 075500 MOVE HDR-6L TO PRINT-RCD.
- 075600 WRITE PRINT-RCD BEFORE 1.
- 075700 MOVE HDR-7L TO PRINT-RCD.
- 075800 WRITE PRINT-RCD BEFORE 1.
- 075900 MOVE HDR-8L TO PRINT-RCD.
- 076000 WRITE PRINT-RCD BEFORE 2.
- 076100 ADD 4 TO LINE-CNT.
- 076200 430-MOVE-CTL-DATA.
- 076300 MOVE RECORD-FORMAT TO REC-TYP-P.
- 076400 MOVE BLM-ADM-ST-W TO BLM-ADM-ST.
- 076500 MOVE BLM-ADM-DIST-W TO BLM-ADM-DIST.
- 076600 MOVE BLM-ADM-RA-W TO BLM-ADM-RA.
- 076700 MOVE BLM-ADM-PLU-W TO BLM-ADM-PLU.
- 076800 MOVE DATA-DATE-W TO DATA-DATE-P.
- 076900 MOVE ACTN-CD-W TO ACTN-CD-P.
- 077000 435-MOVE-DATA.
- 077100 MOVE LIN-NUM-W TO LIN-NUM-P1.
- 077200 MOVE HERD-GRP (1) TO HERD-GRP-WORK.
- 077300 PERFORM 440-MOVE-ALOT-DTD-1.
- 077400 MOVE HERD-GRP (2) TO HERD-GRP-WORK.
- 077500 PERFORM 445-MOVE-ALOT-DTD-2.
- 077600 GO TO 450-EXIT-MOVE.
- 077700 440-MOVE-ALOT-DTD-1.
- 077800 MOVE ALLOT-NUM-L TO ALLOT-NUM-P1.
- 077900 MOVE PASTURE-NUM-L TO PASTURE-NUM-P1.
- 078000 MOVE ANML-GRZG-CD-L TO ANML-GRZG-CD-P1.
- 078100 MOVE ANML-EST-POP-L TO ANML-EST-POP-P1.
- 078200 MOVE USE-DATES-L-1ST-MON TO F-MM-1.
- 078300 MOVE USE-DATES-L-1ST-DAY TO F-DD-1.
- 078400 MOVE USE-DATES-L-END-MON TO T-MM-1.
- 078500 MOVE USE-DATES-L-END-DAY TO T-DD-1.
- 078600 445-MOVE-ALOT-DTD-2.
- 078700 MOVE ALLOT-NUM-L TO ALLOT-NUM-P2.
- 078800 MOVE PASTURE-NUM-L TO PASTURE-NUM-P2.
- 078900 MOVE ANML-GRZG-CD-L TO ANML-GRZG-CD-P2.
- 079000 MOVE ANML-EST-POP-L TO ANML-EST-POP-P2.
- 079100 MOVE USE-DATES-L-1ST-MON TO F-MM-2.
- 079200 MOVE USE-DATES-L-1ST-DAY TO F-DD-2
- 079300 MOVE USE-DATES-L-END-MON TO T-MM-2.
- 079400 MOVE USE-DATES-L-END-DAY TO T-DD-2.
- 079500 450-EXIT-MOVE.
- 079600 EXIT.
- 079700 700-EDIT-VW.
- 079800 PERFORM 145-NEW-PAGE.
- 079900 MOVE "VW" TO VL-VW-TYPE.
- 080000 705-EDIT-FORMAT.
- 080100 IF RECORD-FORMAT = "VW1D"
- 080200 GO TO 710-EXIT-FORMAT.
- 080300 IF REC-TYP-W = "VW"
- 080400 PERFORM 030-EDIT-VL
- 080500 GO TO 710-EXIT-FORMAT.
- 080600 DISPLAY "RECORD NOT PROCESSED***".
- 080700 DISPLAY VL-RCD.
- 080800 READ VL-VW-IN AT END
- 080900 GO TO 9090-END.
- 081000 IF RECORD-FORMAT = "VL1D" OR REC-TYP-W = "VL"
- 081100 DISPLAY "OUT OF SEQUENCE"
- 081200 GO TO 9095-CLOSE.
- 081300 710-EXIT-FORMAT.
- 081400 EXIT.
- 081500 715-BLM-ADM-CHECK.
- 081600 PERFORM 035-EDIT-ST THRU 057-EXIT-BLM.
- 081700 720-ALLOTMENT-W.
- 081800 IF ALLOT-NUM-W NUMERIC GO TO 725-PCT-HERD.
- 081900 MOVE 1 TO HDR-SW2.
- 082000 MOVE ALL "*" TO ASTER-25.
- 082100 725-PCT-HERD.
- 082200 IF HERD-UNIT-ALLOT-PCT NUMERIC OR
- 082300 HERD-UNIT-ALLOT-PCT = SPACES
- 082400 GO TO 730-ANML-SP.
- 082500 MOVE 1 TO HDR-SW2.
- 082600 MOVE ALL "*" TO ASTER-26.
- 082700 730-ANML-SP.
- 082800* MOVE ANML-GRZG-CD-W TO DE-CD-8822-DEC.
- 082900* MOVE 3929 TO DE-NO-8801-DEC.
- 083000* FIND ANY CODE-DEC.
- 083100* MOVE DB-STATUS TO DATA-BASE-STATUS.
- 083200* IF OK
- 083300* GO TO 735-EST-ANML-POP.
- 083400* MOVE 1 TO HDR-SW2.
- 083500* MOVE ALL "*" TO ASTER-27.
- 083600 735-EST-ANML-POP.
- 083700 IF ANML-EST-POP-W NUMERIC OR ANML-EST-POP-W = SPACE
- 083800 GO TO 740-DATES-USE.
- 083900 MOVE 1 TO HDR-SW2.
- 084000 MOVE ALL "*" TO ASTER-28.
- 084100 740-DATES-USE.
- 084200 IF MON-1-W NEXT SENTENCE ELSE
- 084300 MOVE 1 TO HDR-SW2
- 084400 MOVE ALL "*" TO ASTER-29.
- 084500 IF DAY-1-W NEXT SENTENCE ELSE
- 084600 MOVE 1 TO HDR-SW2
- 084700 MOVE ALL "*" TO ASTER-29.
- 084800 IF MON-2-W NEXT SENTENCE ELSE
- 084900 MOVE 1 TO HDR-SW2
- 085000 MOVE ALL "*" TO ASTER-30.
- 085100 IF DAY-2-W NEXT SENTENCE ELSE
- 085200 MOVE 1 TO HDR-SW2
- 085300 MOVE ALL "*" TO ASTER-30.
- 085400 IF (USE-DATES1ST-MON = 04 OR 06 OR 09 OR 11)
- 085500 AND (USE-DATES1ST-DAY = 31)
- 085600 MOVE 1 TO HDR-SW2
- 085700 MOVE ALL "*" TO ASTER-29.
- 085800 IF (USE-DATESEND-MON = 04 OR 06 OR 09 OR 11)
- 085900 AND (USE-DATESEND-DAY = 31)
- 086000 MOVE 1 TO HDR-SW2
- 086100 MOVE ALL "*" TO ASTER-30.
- 086200 IF (USE-DATES1ST-MON = 02)
- 086300 AND (USE-DATES1ST-DAY > 28)
- 086400 MOVE 1 TO HDR-SW2
- 086500 MOVE ALL "*" TO ASTER-29.
- 086600 IF (USE-DATESEND-MON = 02)
- 086700 AND (USE-DATESEND-DAY > 28)
- 086800 MOVE 1 TO HDR-SW2
- 086900 MOVE ALL "*" TO ASTER-30.
- 087000 750-SWA1.
- 087100 IF SWA-GRP = SPACES
- 087200 MOVE ALL "*" TO ASTER-31, ASTER-32,
- 087300 ASTER-33, ASTER-34, ASTER-35
- 087400 MOVE 1 TO HDR-SW2
- 087500 GO TO 775-EDIT-COMPLETE.
- 087600 IF SWA-SET (1) = "9999"
- 087700 GO TO 775-EDIT-COMPLETE.
- 087800 IF SWA-SET (1) = SPACE
- 087900 GO TO 755-SWA2.
- 088000 IF SWACD-W (1) = SPACES
- 088100 MOVE ALL "*" TO ASTER-31
- 088200 MOVE 1 TO HDR-SW2
- 088300 GO TO 755-SWA2.
- 088400 IF SWACD-W (1) NOT ALPHABETIC
- 088500 MOVE ALL "*" TO ASTER-31
- 088600 MOVE 1 TO HDR-SW2
- 088700 GO TO 755-SWA2.
- 088800 IF SWA-THREE (1) NUMERIC
- 088900 GO TO 755-SWA2.
- 089000 MOVE ALL "*" TO ASTER-31.
- 089100 MOVE 1 TO HDR-SW2.
- 089200 755-SWA2.
- 089300 IF SWA-SET (2) = SPACE
- 089400 GO TO 760-SWA3.
- 089500 IF SWACD-W (2) = SPACES
- 089600 MOVE ALL "*" TO ASTER-32
- 089700 MOVE 1 TO HDR-SW2
- 089800 GO TO 760-SWA3.
- 089900 IF SWACD-W (2) NOT ALPHABETIC
- 090000 MOVE ALL "*" TO ASTER-32
- 090100 MOVE 1 TO HDR-SW2
- 090200 GO TO 760-SWA3.
- 090300 IF SWA-THREE (2) NUMERIC
- 090400 GO TO 760-SWA3.
- 090500 MOVE ALL "*" TO ASTER-32.
- 090600 MOVE 1 TO HDR-SW2.
- 090700 760-SWA3.
- 090800 IF SWA-SET (3) = SPACE
- 090900 GO TO 765-SWA4.
- 091000 IF SWACD-W (3) = SPACES
- 091100 MOVE ALL "*" TO ASTER-33
- 091200 MOVE 1 TO HDR-SW2
- 091300 GO TO 765-SWA4.
- 091400 IF SWACD-W (3) NOT ALPHABETIC
- 091500 MOVE ALL "*" TO ASTER-33
- 091600 MOVE 1 TO HDR-SW2
- 091700 GO TO 765-SWA4.
- 091800 IF SWA-THREE (3) NUMERIC
- 091900 GO TO 765-SWA4.
- 092000 MOVE ALL "*" TO ASTER-33.
- 092100 MOVE 1 TO HDR-SW2.
- 092200 765-SWA4.
- 092300 IF SWA-SET (4) = SPACE
- 092400 GO TO 770-SWA5.
- 092500 IF SWACD-W (4) = SPACES
- 092600 MOVE ALL "*" TO ASTER-34
- 092700 MOVE 1 TO HDR-SW2
- 092800 GO TO 770-SWA5.
- 092900 IF SWACD-W (4) NOT ALPHABETIC
- 093000 MOVE ALL "*" TO ASTER-34
- 093100 MOVE 1 TO HDR-SW2
- 093200 GO TO 770-SWA5.
- 093300 IF SWA-THREE (4) NUMERIC
- 093400 GO TO 770-SWA5.
- 093500 MOVE ALL "*" TO ASTER-34.
- 093600 MOVE 1 TO HDR-SW2.
- 093700 770-SWA5.
- 093800 IF SWA-SET (5) = SPACE
- 093900 GO TO 775-EDIT-COMPLETE.
- 094000 IF SWACD-W (5) = SPACES
- 094100 MOVE ALL "*" TO ASTER-35
- 094200 MOVE 1 TO HDR-SW2
- 094300 GO TO 775-EDIT-COMPLETE.
- 094400 IF SWACD-W (5) NOT ALPHABETIC
- 094500 MOVE ALL "*" TO ASTER-35
- 094600 MOVE 1 TO HDR-SW2
- 094700 GO TO 775-EDIT-COMPLETE.
- 094800 IF SWA-THREE (5) NUMERIC
- 094900 GO TO 775-EDIT-COMPLETE.
- 095000 MOVE ALL "*" TO ASTER-35.
- 095100 MOVE 1 TO HDR-SW2.
- 095200 775-EDIT-COMPLETE.
- 095300 EXIT.
- 095400 776-HDR-CHECK.
- 095500 IF HDR-SW1 = ZERO
- 095600 GO TO 795-HDR-SW2.
- 095700 IF PAGE-SW = 1
- 095800 PERFORM 415-HDR-ST-DIST
- 095900 MOVE ZERO TO PAGE-SW.
- 096000 PERFORM 420-HDRS-CNTL.
- 096100 780-WRITE-CNTL.
- 096200 PERFORM 430-MOVE-CTL-DATA.
- 096300 MOVE PRINT-1LW TO PRINT-RCD.
- 096400 WRITE PRINT-RCD BEFORE 1.
- 096500 MOVE PRINT-2LW TO PRINT-RCD.
- 096600 WRITE PRINT-RCD BEFORE 2.
- 096700 ADD 3 TO LINE-CNT.
- 096800 MOVE 1 TO ERROR-SW.
- 096900 785-WRITE-DATA.
- 097000 PERFORM 900-HDRS-W THRU 910-DATA-W.
- 097100 MOVE PRINT-5W TO PRINT-RCD.
- 097200 WRITE PRINT-RCD BEFORE 1.
- 097300 IF HDR-SW2 = 1
- 097400 MOVE PRINT-6W TO PRINT-RCD
- 097500 MOVE 1 TO ERROR-SW
- 097600 ELSE
- 097700 MOVE SPACE TO PRINT-RCD.
- 097800 WRITE PRINT-RCD BEFORE 2.
- 097900 ADD 3 TO LINE-CNT.
- 098000 790-DUMMY.
- 098100 GO TO 800-NEW-RCD.
- 098200 795-HDR-SW2.
- 098300 IF HDR-SW2 = ZERO
- 098400 GO TO 800-NEW-RCD.
- 098500 IF PAGE-SW = ZERO
- 098600 PERFORM 785-WRITE-DATA
- 098700 GO TO 800-NEW-RCD.
- 098800 PERFORM 415-HDR-ST-DIST THRU 420-HDRS-CNTL.
- 098900 MOVE ZERO TO PAGE-SW.
- 099000 PERFORM 780-WRITE-CNTL THRU 785-WRITE-DATA.
- 099100 800-NEW-RCD.
- 099200 IF HERD-UNIT-ALLOT-PCT = SPACE
- 099300 MOVE ZERO TO HERD-UNIT-ALLOT-PCT.
- 099400 IF ANML-EST-POP-W = SPACE
- 099500 MOVE ZERO TO ANML-EST-POP-W.
- 099600 MOVE VW-RCD TO VL-VW-RCD.
- 099700 WRITE VL-VW-RCD.
- 099800 GO TO 810-READ-NEXT.
- 099900 805-ZERO-OUT.
- 100000 MOVE ZERO TO HDR-SW1, HDR-SW2
- 100100 MOVE SPACE TO PRINT-2LW, PRINT-6W.
- 100200 810-READ-NEXT.
- 100300 READ VL-VW-IN AT END
- 100400 GO TO 9090-END.
- 100500 PERFORM 705-EDIT-FORMAT THRU 710-EXIT-FORMAT.
- 100600 815-BLM-ST.
- 100700 IF BLM-ADM-ST-W = ST-HOLD
- 100800 GO TO 820-BLM-DIST.
- 100900 PERFORM 145-NEW-PAGE.
- 101000 GO TO 715-BLM-ADM-CHECK.
- 101100 820-BLM-DIST.
- 101200 IF BLM-ADM-DIST-W = DT-HOLD
- 101300 GO TO 825-BLM-RA.
- 101400 PERFORM 145-NEW-PAGE.
- 101500 GO TO 715-BLM-ADM-CHECK.
- 101600 825-BLM-RA.
- 101700 IF BLM-ADM-RA-W = RA-HOLD
- 101800 GO TO 830-BLM-PLU.
- 101900 MOVE 1 TO PAGE-SW.
- 102000 PERFORM 125-ZERO-OUT.
- 102100 PERFORM 020-HOLD.
- 102200 GO TO 715-BLM-ADM-CHECK.
- 102300 830-BLM-PLU.
- 102400 IF BLM-ADM-PLU-W = PLU-HOLD
- 102500 GO TO 840-EDIT-NEXT.
- 102600 MOVE 1 TO PAGE-SW.
- 102700 PERFORM 125-ZERO-OUT.
- 102800 PERFORM 020-HOLD.
- 102900 GO TO 715-BLM-ADM-CHECK.
- 103000 840-EDIT-NEXT.
- 103100 MOVE SPACE TO PRINT-6W.
- 103200 MOVE ZERO TO HDR-SW2.
- 103300 PERFORM 720-ALLOTMENT-W THRU 775-EDIT-COMPLETE.
- 103400 IF HDR-SW1 NOT = TO ZERO
- 103500 GO TO 841-PAGE.
- 103600 IF HDR-SW2 = ZERO
- 103700 GO TO 800-NEW-RCD.
- 103800 841-PAGE.
- 103900 IF PAGE-SW = ZERO
- 104000 GO TO 850-CONTINUE.
- 104100 MOVE ZERO TO PAGE-SW.
- 104200 PERFORM 415-HDR-ST-DIST THRU 420-HDRS-CNTL.
- 104300 PERFORM 430-MOVE-CTL-DATA.
- 104400 MOVE PRINT-1LW TO PRINT-RCD.
- 104500 WRITE PRINT-RCD BEFORE 1.
- 104600 IF HDR-SW1 = ZERO
- 104700 MOVE SPACE TO PRINT-RCD
- 104800 ELSE
- 104900 MOVE PRINT-2LW TO PRINT-RCD
- 105000 MOVE 1 TO ERROR-SW.
- 105100 WRITE PRINT-RCD BEFORE 2.
- 105200 ADD 3 TO LINE-CNT.
- 105300 PERFORM 900-HDRS-W.
- 105400 850-CONTINUE.
- 105500 PERFORM 910-DATA-W.
- 105600 MOVE PRINT-5W TO PRINT-RCD.
- 105700 WRITE PRINT-RCD BEFORE 1.
- 105800 IF HDR-SW2 = ZERO
- 105900 MOVE SPACE TO PRINT-RCD
- 106000 ELSE
- 106100 MOVE PRINT-6W TO PRINT-RCD
- 106200 MOVE 1 TO ERROR-SW.
- 106300 WRITE PRINT-RCD BEFORE 2.
- 106400 ADD 3 TO LINE-CNT.
- 106500 IF LINE-CNT > 54
- 106600 MOVE 1 TO PAGE-SW.
- 106700 GO TO 800-NEW-RCD.
- 106800 900-HDRS-W.
- 106900 MOVE HDR-9W TO PRINT-RCD.
- 107000 WRITE PRINT-RCD BEFORE 1.
- 107100 MOVE HDR-10W TO PRINT-RCD.
- 107200 WRITE PRINT-RCD BEFORE 1.
- 107300 MOVE HDR-11W TO PRINT-RCD.
- 107400 WRITE PRINT-RCD BEFORE 2.
- 107500 ADD 4 TO LINE-CNT.
- 107600 910-DATA-W.
- 107700 MOVE LIN-NUM-W TO LIN-NUM-P3.
- 107800 MOVE HERD-UNIT-NUM-W TO HERD-NO-P3.
- 107900 MOVE ALLOT-NUM-W TO ALLOT-NUM-P3.
- 108000 MOVE HERD-UNIT-ALLOT-PCT TO PCT-HERD-P3.
- 108100 MOVE ANML-GRZG-CD-W TO ANML-GRZG-CD-P3.
- 108200 MOVE ANML-EST-POP-W TO ANML-EST-POP-P3.
- 108300 MOVE USE-DATES1ST-MON TO F-MM-3.
- 108400 MOVE USE-DATES1ST-DAY TO F-DD-3.
- 108500 MOVE USE-DATESEND-MON TO T-MM-4.
- 108600 MOVE USE-DATESEND-DAY TO T-DD-4.
- 108700 MOVE SWA-SET (1) TO SWA-1P.
- 108800 MOVE SWA-SET (2) TO SWA-2P.
- 108900 MOVE SWA-SET (3) TO SWA-3P.
- 109000 MOVE SWA-SET (4) TO SWA-4P.
- 109100 MOVE SWA-SET (5) TO SWA-5P.
- 109200 9090-END.
- 109300 IF ERROR-SW = 1
- 109400 PERFORM 400-LINE-CNT
- 109500 GO TO 9095-CLOSE.
- 109600 DISPLAY "NO ERRORS DETECTED ON THESE RECORDS".
- 109700 9095-CLOSE.
- 109800 CLOSE VL-VW-IN, VL-VW-OUT, PRINT-FILE.
- 109900 FINISH.
- 110000 STOP RUN.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES510P.
- 000300* ALLOTMENT LEVEL ACREAGE (P1 LIST)
- 000400*
- 000500 AUTHOR. M.QUANDT.
- 000600 ENVIRONMENT DIVISION.
- 000700 CONFIGURATION SECTION.
- 000800 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 000900 OBJECT-COMPUTER. LEVEL-66-ASCII.
- 001000 INPUT-OUTPUT SECTION.
- 001100 FILE-CONTROL.
- 001200 SELECT INPUT-FILE ASSIGN TO I1
- 001300 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001400 SELECT PRINT-OUT ASSIGN TO P1
- 001500 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001600 DATA DIVISION.
- 001700 SUB-SCHEMA SECTION.
- 001800 DB CODVAL2 WITHIN BLMDIC.
- 001900 FILE SECTION.
- 002000 FD INPUT-FILE
- 002100 CODE-SET IS GBCD
- 002200 LABEL RECORDS ARE STANDARD.
- 002300 01 IN-RECORD.
- 002400 05 REC-TYP PIC XX.
- 002500 05 FMT-NUM PIC X.
- 002600 05 FORMAT-CD PIC X.
- 002700 05 BLM-ADM-U PIC X(8).
- 002800 05 ALLOT-NUM PIC X(4).
- 002900 05 PASTURE-NUM PIC XX.
- 003000 05 DATA-DATE PIC X(6).
- 003100 05 ACTION-CD PIC X.
- 003200 05 MAP-SRC PIC X(4).
- 003300 05 IN-MTR-MER-CD PIC XX.
- 003400 05 LIN-NUM PIC X(4).
- 003500 05 MTR-TWSHP PIC X(5).
- 003600 05 IN-MTR-RNG PIC X(5).
- 003700 05 IN-SEC-SECT PIC XXX.
- 003800 05 SWA PIC X(4).
- 003900 05 FILLER PIC X(16).
- 004000 05 ACR-DU PIC 9(5).
- 004100 05 COMBO.
- 004200 10 OWN-TYP PIC X(4).
- 004300 10 JURIS PIC X(4).
- 004400 10 IN-ADMIN PIC X(4).
- 004500 10 LAND-TYP PIC X(4).
- 004600 05 FILLER PIC X.
- 004700 FD PRINT-OUT
- 004800 CODE-SET IS GBCD
- 004900 LABEL RECORDS ARE STANDARD.
- 005000 01 PRINT-LINE PIC X(132).
- 005100 WORKING-STORAGE SECTION.
- 005200 77 NEW-ALLOT PIC X(4).
- 005300 77 SUB-CHK PIC 9(4) VALUE ZERO.
- 005400 77 OLD-ALLOT PIC X(4).
- 005500 77 NEW-PASTURE PIC XX.
- 005600 77 OLD-PASTURE PIC XX.
- 005700 77 NEW-SWA PIC X(4).
- 005800 77 OLD-SWA PIC X(4).
- 005900 77 NEW-SKEY PIC X(8).
- 006000 77 OLD-SKEY PIC X(8).
- 006100 77 PAGE-COUNT PIC 9(5) VALUE ZERO.
- 006200 77 LINE-COUNT PIC 99 VALUE ZERO.
- 006300 77 READ-COUNT PIC 9(7) VALUE ZEROS.
- 006400 77 DATA-PRINT-COUNT PIC 9(7) VALUE ZEROS.
- 006500 77 WORK-SPACES PIC X(132) VALUE SPACES.
- 006600 77 WORK-PRINT PIC X(132).
- 006700 77 TOTAL-SWA-ACRES PIC 9(7) VALUE ZERO.
- 006800 77 TOTAL-PASTURE-ACRES PIC 9(7) VALUE ZERO.
- 006900 77 TOTAL-ALLOT-ACRES PIC 9(7) VALUE ZERO.
- 007000 77 SUB-SCRIPT PIC 9999 VALUE ZERO.
- 007100 77 FIND-SCRIPT PIC 9999 VALUE ZERO.
- 007200 77 SAVE-PASTURE PIC XX.
- 007300 77 WS-PASTURE PIC XX.
- 007400 77 SAVE-ALLOTMENT PIC 9(4).
- 007500 01 HOLD-AREA.
- 007600 03 ADST-DIST-RA-PLU-CDS-H.
- 007700 05 ADST-CD-H PIC XX.
- 007800 05 DIST-CD-H PIC XX.
- 007900 05 RA-CD-H PIC XX.
- 008000 05 PLU-CD-H PIC XX.
- 008100 03 DE-CD-EXPLN-8827-DECE-H.
- 008200 05 DIST-NAM-H PIC X(12).
- 008300 05 RA-NAM-H PIC X(13).
- 008400 05 PLU-NAM-H PIC X(15).
- 008500 03 DE-CD-NAM-8823-DEC-H.
- 008600 05 ST-NAM-H PIC X(10).
- 008700 05 FILLER PIC X(14).
- 008800 01 PAG-HDR-1.
- 008900 03 FILLER PIC X(13) VALUE "REPORT DATE: ".
- 009000 03 HEADER-DATE.
- 009100 05 MO-HDR PIC 99.
- 009200 05 FILLER PIC X VALUE "/".
- 009300 05 DA-HDR PIC 99.
- 009400 05 FILLER PIC X VALUE "/".
- 009500 05 YR-HDR PIC 99.
- 009600 03 FILLER PIC X(28) VALUE SPACES.
- 009700 03 FILLER PIC X(23) VALUE "U.S.D.I. BUREAU OF LAND".
- 009800 03 FILLER PIC X(11) VALUE " MANAGEMENT".
- 009900 03 FILLER PIC X(22) VALUE SPACES.
- 010000 03 FILLER PIC X(15) VALUE "PCN: P010 ".
- 010100 03 FILLER PIC X(6) VALUE " PAGE ".
- 010200 03 PAGE-NO PIC ZZ,ZZ9.
- 010300 01 PAG-HDR-3.
- 010400 03 FILLER PIC X(20) VALUE " STATE ".
- 010500 03 STATE-NAME PIC X(10).
- 010600 03 FILLER PIC X(24) VALUE SPACES.
- 010700 03 FILLER PIC X(21) VALUE "ECOLOGICAL SITE INVEN".
- 010800 03 FILLER PIC X(04) VALUE "TORY".
- 010900 03 FILLER PIC X(53) VALUE SPACES.
- 011000 01 PAG-HDR-4.
- 011100 03 FILLER PIC X(20) VALUE " DISTRICT ".
- 011200 03 DIST-NAME PIC X(12).
- 011300 03 FILLER PIC X(100) VALUE SPACES.
- 011400 01 PAG-HDR-5.
- 011500 03 FILLER PIC X(20) VALUE " RESOURCE AREA ".
- 011600 03 RA-NAME PIC X(13).
- 011700 03 FILLER PIC X(16) VALUE SPACES.
- 011800 03 FILLER PIC X(21) VALUE "ALLOTMENT LEVEL ACREA".
- 011900 03 FILLER PIC X(14) VALUE "GE INFORMATION".
- 012000 03 FILLER PIC X(48) VALUE SPACES.
- 012100 01 PAG-HDR-6.
- 012200 03 FILLER PIC X(20) VALUE " PLANNING UNIT ".
- 012300 03 PU-NAME PIC X(15).
- 012400 03 FILLER PIC X(97) VALUE SPACES.
- 012500 01 COL-HDR-1.
- 012600 03 FILLER PIC X(59) VALUE SPACES.
- 012700 03 FILLER PIC X(10) VALUE "TYPE MAP ".
- 012800 03 FILLER PIC X(63) VALUE SPACES.
- 012900 01 COL-HDR-2.
- 013000 03 FILLER PIC X(21) VALUE " ALLOTMENT PASTUR".
- 013100 03 FILLER PIC X(21) VALUE "E SWA ACRES OWNE".
- 013200 03 FILLER PIC X(21) VALUE "R JURIS ADMIN LAND".
- 013300 03 FILLER PIC X(21) VALUE " SOURCE MERID TOWN".
- 013400 03 FILLER PIC X(21) VALUE "SHIP RANGE SEC ALI".
- 013500 03 FILLER PIC X(21) VALUE "QUOT PARTS ".
- 013600 03 FILLER PIC X(6) VALUE SPACES.
- 013700 01 DATA-LINE-1.
- 013800 03 FILLER PIC X(6).
- 013900 03 ALLOT-NO-P PIC 9999.
- 014000 03 FILLER PIC X(7).
- 014100 03 PASTURE-P PIC XX.
- 014200 03 FILLER PIC X(4).
- 014300 03 SWA-P PIC X(4).
- 014400 03 FILLER PIC XX.
- 014500 03 ACRES-P PIC Z(6)9.
- 014600 03 FILLER PIC XX.
- 014700 03 OWNER-P PIC X(4).
- 014800 03 FILLER PIC XXX.
- 014900 03 JURIS-P PIC X(4).
- 015000 03 FILLER PIC XXX.
- 015100 03 ADMIN-P PIC X(4).
- 015200 03 FILLER PIC XXX.
- 015300 03 LAND-TYPE-P PIC X(4).
- 015400 03 FILLER PIC XXX.
- 015500 03 MAP-SPCE-P PIC X(4).
- 015600 03 FILLER PIC X(4).
- 015700 03 MERID-P PIC Z9.
- 015800 03 FILLER PIC X(5).
- 015900 03 TWNSHP-P PIC X(5).
- 016000 03 FILLER PIC X(4).
- 016100 03 RNGE-P PIC X(5).
- 016200 03 FILLER PIC XX.
- 016300 03 SECT-P PIC XXX.
- 016400 03 FILLER PIC XX.
- 016500 03 ALIQ-PTS-P PIC X(19).
- 016600 03 FILLER PIC X(11).
- 016700 01 DATA-LINE-2 REDEFINES DATA-LINE-1 PIC X(132).
- 016800 01 SWA-TOTAL-LINE.
- 016900 03 FILLER PIC X(6) VALUE SPACES.
- 017000 03 ALLT-P PIC 9(4).
- 017100 03 FILLER PIC X(7) VALUE SPACES.
- 017200 03 PASTR-P PIC XX.
- 017300 03 FILLER PIC XXX VALUE SPACES.
- 017400 03 TOTALL-P PIC X(5) VALUE "TOTAL".
- 017500 03 FILLER PIC XX VALUE SPACES.
- 017600 03 TOTL-ACRS PIC Z(6)9.
- 017700 03 FILLER PIC X(96) VALUE SPACES.
- 017800 01 PASTURE-TOTAL-LINE.
- 017900 03 FILLER PIC X(6) VALUE SPACES.
- 018000 03 ALLOT-P PIC 9(4).
- 018100 03 FILLER PIC X(5) VALUE SPACES.
- 018200 03 PAS-TOT-P PIC X(5) VALUE "TOTAL".
- 018300 03 FILLER PIC X(9) VALUE SPACES.
- 018400 03 ACRS-P PIC Z(6)9.
-
- 018500 03 FILLER PIC X(96) VALUE SPACES.
- 018600 01 ALLOTMENT-TOTAL-LINE.
- 018700 03 FILLER PIC X(6) VALUE SPACES.
- 018800 03 ALLOT-TOT-P PIC X(5) VALUE "TOTAL".
- 018900 03 FILLER PIC X(18) VALUE SPACES.
- 019000 03 ACRES-P PIC Z(6)9.
- 019100 03 FILLER PIC X(96) VALUE SPACES.
- 019200 01 OWNER-SUMMARY-LINE-1.
- 019300 03 FILLER PIC X(17) VALUE "OWNERSHIP SUMMARY".
- 019400 03 FILLER PIC X(12) VALUE SPACES.
- 019500 03 ACRE-SUM-P PIC Z(6)9.
- 019600 03 FILLER PIC XX VALUE SPACES.
- 019700 03 OWNR-SUM-P PIC X(4).
- 019800 03 FILLER PIC XXX VALUE SPACES.
- 019900 03 JURIS-SUM-P PIC X(4).
- 020000 03 FILLER PIC XXX VALUE SPACES.
- 020100 03 ADMIN-SUM-P PIC X(4).
- 020200 03 FILLER PIC XXX VALUE SPACES.
- 020300 03 LND-TYP-SUM-P PIC X(4).
- 020400 03 FILLER PIC X(69) VALUE SPACES.
- 020500 01 OWNER-SUMMARY-LINE-2.
- 020600 03 FILLER PIC X(14) VALUE " FOR ALLOTMENT".
- 020700 03 FILLER PIC X(15) VALUE SPACES.
- 020800 03 ACRE-SUM-2 PIC Z(6)9.
- 020900 03 FILLER PIC XX VALUE SPACES.
- 021000 03 OWNR-SUM-2 PIC X(4).
- 021100 03 FILLER PIC XXX VALUE SPACES.
- 021200 03 JURIS-SUM-2 PIC X(4).
- 021300 03 FILLER PIC X VALUE SPACES.
- 021400 03 ADMIN-SUM-2 PIC X(8).
- 021500 03 FILLER PIC X VALUE SPACES.
- 021600 03 LND-TYP-SUM-2 PIC X(4).
- 021700 03 FILLER PIC X(69) VALUE SPACES.
- 021800 01 OWNER-SUMMARY-LINE-3.
- 021900 03 FILLER PIC X(29) VALUE SPACES.
- 022000 03 ACRE-SUM-3 PIC Z(6)9.
- 022100 03 FILLER PIC XX VALUE SPACES.
- 022200 03 OWNR-SUM-3 PIC X(4).
- 022300 03 FILLER PIC XXX VALUE SPACES.
- 022400 03 JURIS-SUM-3 PIC X(4).
- 022500 03 FILLER PIC X VALUE SPACES.
- 022600 03 ADMIN-SUM-3 PIC X(8).
- 022700 03 FILLER PIC X VALUE SPACES.
- 022800 03 LND-TYP-SUM-3 PIC X(4).
- 022900 03 FILLER PIC X(69) VALUE SPACES.
- 023000 01 DATE-TODAY.
- 023100 05 THIS-YEAR PIC 99.
- 023200 05 THIS-MONTH PIC 99.
- 023300 05 THIS-DAY PIC 99.
- 023400 01 EOF-CONDITION PIC 9.
- 023500 88 FILE-END VALUE IS 1.
- 023600 01 FIRST-DATA-CONDITION PIC 9.
- 023700 88 FIRST-DATA-LINE VALUE IS 1.
- 023800 01 COMBO-TABLE.
- 023900 05 TABLE-ELEMENT OCCURS 200 TIMES.
- 024000 10 COMBO-ELEMENT.
- 024100 15 OWNER-ELEMENT PIC X(4).
- 024200 15 JURIS-ELEMENT PIC X(4).
- 024300 15 ADMIN-ELEMENT PIC X(4).
- 024400 15 LAND-TYPE-ELEMENT PIC X(4).
- 024500 10 TOTAL-ELEMENT PIC 9(7).
- 024600 01 OWNER-LINE2-SPACES.
- 024700 05 FILLER PIC X(14) VALUE " FOR ALLOTMENT".
- 024800 05 FILLER PIC X(118) VALUE SPACES.
- 024900 PROCEDURE DIVISION.
- 025000 10-HOUSEKEEPING.
- 025100 PERFORM 200-HOUSEKEEP.
- 025200 20-READ-PROCESS.
- 025300 PERFORM 210-READ-INPUT.
- 025400 IF FILE-END
- 025500 PERFORM 900-WRAPUP
- 025600 STOP RUN.
- 025700 IF PASTURE-NUM EQUAL "00"
- 025800 MOVE SPACES TO WS-PASTURE
- 025900 ELSE MOVE PASTURE-NUM TO WS-PASTURE.
- 026000 PERFORM 225-SKEY-CHANGE.
- 026100 PERFORM 230-ALLOT-CHANGE.
- 026200 PERFORM 240-PASTURE-CHANGE.
- 026300 PERFORM 250-SWA-CHANGE.
- 026400 IF NEW-ALLOT NOT EQUAL OLD-ALLOT
- 026500 OR NEW-SKEY NOT EQUAL OLD-SKEY
- 026600 PERFORM 500-SWA-TOTAL THRU 539-EXIT
- 026700 PERFORM 215-SKEY-TO-HDR THRU 220-TOP-PAGE
- 026800 GO TO 30-ADD-WRITE.
- 026900 IF NEW-PASTURE NOT EQUAL OLD-PASTURE
- 027000 PERFORM 500-SWA-TOTAL THRU 510-PASTURE-TOTAL
- 027100 GO TO 30-ADD-WRITE.
- 027200 IF NEW-SWA NOT EQUAL OLD-SWA
- 027300 PERFORM 500-SWA-TOTAL.
- 027400 30-ADD-WRITE.
- 027500 PERFORM 700-SWA-ADD THRU 720-MOVE-TO-OUTPUT.
- 027600 GO TO 20-READ-PROCESS.
- 027700 200-HOUSEKEEP.
- 027800 READY DIC-DE.
- 027900 INITIALIZE COMBO-TABLE.
- 028000 MOVE 1 TO FIRST-DATA-CONDITION.
- 028100 MOVE ZERO TO EOF-CONDITION.
- 028200 OPEN INPUT INPUT-FILE OUTPUT PRINT-OUT.
- 028300 ACCEPT DATE-TODAY FROM DATE.
- 028400 MOVE THIS-DAY TO DA-HDR.
- 028500 MOVE THIS-MONTH TO MO-HDR.
- 028600 MOVE THIS-YEAR TO YR-HDR.
- 028700 PERFORM 210-READ-INPUT.
- 028800 IF FILE-END
- 028900 DISPLAY "NO RECORD IN INPUT FILE"
- 029000 CLOSE INPUT-FILE PRINT-OUT
- 029100 STOP RUN.
- 029200 IF PASTURE-NUM EQUAL "00"
- 029300 MOVE SPACES TO WS-PASTURE
- 029400 ELSE MOVE PASTURE-NUM TO WS-PASTURE.
- 029500 PERFORM 215-SKEY-TO-HDR THRU 220-TOP-PAGE.
- 029600 PERFORM 700-SWA-ADD.
- 029700 MOVE COMBO TO COMBO-ELEMENT ( 1 ).
- 029800 MOVE ACR-DU TO TOTAL-ELEMENT ( 1 ).
- 029900 PERFORM 720-MOVE-TO-OUTPUT.
- 030000 MOVE SWA TO NEW-SWA.
- 030100 MOVE PASTURE-NUM TO NEW-PASTURE.
- 030200 MOVE ALLOT-NUM TO NEW-ALLOT.
- 030300 MOVE BLM-ADM-U TO NEW-SKEY.
- 030400 210-READ-INPUT.
- 030500 READ INPUT-FILE
- 030600 AT END MOVE 1 TO EOF-CONDITION
- 030700 SUBTRACT 1 FROM READ-COUNT.
- 030800 ADD 1 TO READ-COUNT.
- 030900 215-SKEY-TO-HDR.
- 031000 MOVE 0003 TO DE-NO-8801-DEC.
- 031100 MOVE BLM-ADM-U TO DE-CD-8822-DEC.
- 031200 FIND ANY CODE-DEC.
- 031300 IF DB-STATUS NOT = ZERO
- 031400 DISPLAY "BAD STATE CODE" CALL "ABOR".
- 031500 GET CODE-DEC.
- 031600 MOVE DE-CD-NAM-8823-DEC TO DE-CD-NAM-8823-DEC-H.
- 031700 FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
- 031800 IF DB-STATUS NOT = ZERO
- 031900 DISPLAY "BAD DIST, RA, PLU CODES" CALL "ABOR".
- 032000 GET CODE-EXPL-DECE.
- 032100 MOVE DE-CD-EXPLN-8827-DECE TO DE-CD-EXPLN-8827-DECE-H.
- 032200 MOVE ST-NAM-H TO STATE-NAME.
- 032300 MOVE RA-NAM-H TO RA-NAME.
- 032400 MOVE DIST-NAM-H TO DIST-NAME.
- 032500 MOVE PLU-NAM-H TO PU-NAME.
- 032600 220-TOP-PAGE.
- 032700 ADD 1 TO PAGE-COUNT.
- 032800 MOVE PAGE-COUNT TO PAGE-NO.
- 032900 IF PAGE-COUNT = 1
- 033000 DISPLAY PAG-HDR-1
- 033100 DISPLAY PAG-HDR-3
- 033200 DISPLAY PAG-HDR-4
- 033300 DISPLAY PAG-HDR-5
- 033400 DISPLAY PAG-HDR-6
- 033500 DISPLAY COL-HDR-1
- 033600 DISPLAY COL-HDR-2
- 033700 DISPLAY SPACES.
- 033800 WRITE PRINT-LINE FROM PAG-HDR-1
- 033900 AFTER ADVANCING PAGE.
- 034000 WRITE PRINT-LINE FROM PAG-HDR-3
- 034100 AFTER ADVANCING 1 LINE.
- 034200 WRITE PRINT-LINE FROM PAG-HDR-4
- 034300 AFTER ADVANCING 1 LINE.
- 034400 WRITE PRINT-LINE FROM PAG-HDR-5
- 034500 AFTER ADVANCING 1 LINE.
- 034600 WRITE PRINT-LINE FROM PAG-HDR-6
- 034700 AFTER ADVANCING 1 LINE.
- 034800 WRITE PRINT-LINE FROM COL-HDR-1
- 034900 AFTER ADVANCING 1 LINE.
- 035000 WRITE PRINT-LINE FROM COL-HDR-2
- 035100 AFTER ADVANCING 1 LINE.
- 035200 WRITE PRINT-LINE FROM WORK-SPACES
- 035300 AFTER ADVANCING 1 LINE.
- 035400 MOVE 9 TO LINE-COUNT.
- 035500 225-SKEY-CHANGE.
- 035600 MOVE NEW-SKEY TO OLD-SKEY.
- 035700 MOVE BLM-ADM-U TO NEW-SKEY.
- 035800 230-ALLOT-CHANGE.
- 035900 MOVE NEW-ALLOT TO OLD-ALLOT.
- 036000 MOVE ALLOT-NUM TO NEW-ALLOT.
- 036100 240-PASTURE-CHANGE.
- 036200 MOVE NEW-PASTURE TO OLD-PASTURE.
- 036300 MOVE PASTURE-NUM TO NEW-PASTURE.
- 036400 250-SWA-CHANGE.
- 036500 MOVE NEW-SWA TO OLD-SWA.
- 036600 MOVE SWA TO NEW-SWA.
- 036700 260-WRITE-OUTPUT.
- 036800 IF LINE-COUNT GREATER 54
- 036900 PERFORM 220-TOP-PAGE.
- 037000 IF PAGE-COUNT = 1
- 037100 DISPLAY WORK-PRINT.
- 037200 WRITE PRINT-LINE FROM WORK-PRINT
- 037300 AFTER ADVANCING 1 LINE.
- 037400 ADD 1 TO LINE-COUNT.
- 037500 500-SWA-TOTAL.
- 037600 MOVE SPACES TO WORK-PRINT.
- 037700 PERFORM 260-WRITE-OUTPUT.
- 037800 MOVE SAVE-ALLOTMENT TO ALLT-P.
- 037900 MOVE SAVE-PASTURE TO PASTR-P.
- 038000 MOVE TOTAL-SWA-ACRES TO TOTL-ACRS.
- 038100 MOVE SWA-TOTAL-LINE TO WORK-PRINT.
- 038200 PERFORM 260-WRITE-OUTPUT.
- 038300 ADD TOTAL-SWA-ACRES TO TOTAL-PASTURE-ACRES.
- 038400 MOVE ZEROS TO TOTAL-SWA-ACRES.
- 038500 MOVE 1 TO FIRST-DATA-CONDITION.
- 038600 510-PASTURE-TOTAL.
- 038700 MOVE SPACES TO WORK-PRINT.
- 038800 PERFORM 260-WRITE-OUTPUT.
- 038900 MOVE SAVE-ALLOTMENT TO ALLOT-P.
- 039000 MOVE TOTAL-PASTURE-ACRES TO ACRS-P.
- 039100 MOVE PASTURE-TOTAL-LINE TO WORK-PRINT.
- 039200 PERFORM 260-WRITE-OUTPUT.
- 039300 ADD TOTAL-PASTURE-ACRES TO TOTAL-ALLOT-ACRES.
- 039400 MOVE ZEROS TO TOTAL-PASTURE-ACRES.
- 039500 520-ALLOT-TOTAL.
- 039600 MOVE SPACES TO WORK-PRINT.
- 039700 PERFORM 260-WRITE-OUTPUT.
- 039800 MOVE TOTAL-ALLOT-ACRES TO ACRES-P OF ALLOTMENT-TOTAL-LINE.
- 039900 MOVE ALLOTMENT-TOTAL-LINE TO WORK-PRINT.
- 040000 PERFORM 260-WRITE-OUTPUT.
- 040100 MOVE ZEROS TO TOTAL-ALLOT-ACRES.
- 040200 MOVE SPACES TO WORK-PRINT.
- 040300 PERFORM 260-WRITE-OUTPUT.
- 040400 530-OWN-SUM.
- 040500 ADD 1 TO SUB-SCRIPT.
- 040600 IF SUB-SCRIPT > SUB-CHK
- 040700 MOVE SUB-SCRIPT TO SUB-CHK.
- 040800 IF COMBO-ELEMENT ( SUB-SCRIPT ) EQUAL SPACES
- 040900 OR SUB-SCRIPT GREATER 200
- 041000 GO TO 535-FINISH.
- 041100 IF SUB-SCRIPT EQUAL 1
- 041200 MOVE TOTAL-ELEMENT ( 1 ) TO ACRE-SUM-P
- 041300 MOVE OWNER-ELEMENT ( 1 ) TO OWNR-SUM-P
- 041400 MOVE JURIS-ELEMENT ( 1 ) TO JURIS-SUM-P
- 041500 MOVE ADMIN-ELEMENT ( 1 ) TO ADMIN-SUM-P
- 041600 MOVE LAND-TYPE-ELEMENT ( 1 ) TO LND-TYP-SUM-P
- 041700 MOVE OWNER-SUMMARY-LINE-1 TO WORK-PRINT
- 041800 PERFORM 260-WRITE-OUTPUT
- 041900 GO TO 530-OWN-SUM.
- 042000 IF SUB-SCRIPT EQUAL 2
- 042100 MOVE TOTAL-ELEMENT ( 2 ) TO ACRE-SUM-2
- 042200 MOVE OWNER-ELEMENT ( 2 ) TO OWNR-SUM-2
- 042300 MOVE JURIS-ELEMENT ( 2 ) TO JURIS-SUM-2
- 042400 MOVE ADMIN-ELEMENT ( 2 ) TO ADMIN-SUM-2
- 042500 MOVE LAND-TYPE-ELEMENT ( 2 ) TO LND-TYP-SUM-2
- 042600 MOVE OWNER-SUMMARY-LINE-2 TO WORK-PRINT
- 042700 PERFORM 260-WRITE-OUTPUT
- 042800 GO TO 530-OWN-SUM.
- 042900 MOVE TOTAL-ELEMENT ( SUB-SCRIPT ) TO ACRE-SUM-3.
- 043000 MOVE OWNER-ELEMENT ( SUB-SCRIPT ) TO OWNR-SUM-3.
- 043100 MOVE JURIS-ELEMENT ( SUB-SCRIPT ) TO JURIS-SUM-3.
- 043200 MOVE ADMIN-ELEMENT ( SUB-SCRIPT ) TO ADMIN-SUM-3.
- 043300 MOVE LAND-TYPE-ELEMENT ( SUB-SCRIPT ) TO LND-TYP-SUM-3.
- 043400 MOVE OWNER-SUMMARY-LINE-3 TO WORK-PRINT
- 043500 PERFORM 260-WRITE-OUTPUT
- 043600 GO TO 530-OWN-SUM.
- 043700 535-FINISH.
- 043800 IF SUB-SCRIPT EQUAL 2
- 043900 MOVE OWNER-LINE2-SPACES TO WORK-PRINT
- 044000 PERFORM 260-WRITE-OUTPUT.
- 044100 536-RE-INITIALIZE.
- 044200 MOVE ZEROS TO SUB-SCRIPT.
- 044300 INITIALIZE COMBO-TABLE.
- 044400 539-EXIT.
- 044500 700-SWA-ADD.
- 044600 ADD ACR-DU TO TOTAL-SWA-ACRES.
- 044700 710-COMBO-ADD.
- 044800 ADD 1 TO FIND-SCRIPT.
- 044900 IF FIND-SCRIPT GREATER 200
- 045000 DISPLAY "TABLE TOO SMALL"
- 045100 DISPLAY "RECOMPILE AND RERUN"
- 045200 CALL "TBLE-TOO-SMALL".
- 045300 IF COMBO-ELEMENT ( FIND-SCRIPT ) EQUAL SPACES
- 045400 MOVE COMBO TO COMBO-ELEMENT ( FIND-SCRIPT )
- 045500 MOVE ACR-DU TO TOTAL-ELEMENT ( FIND-SCRIPT )
- 045600 GO TO 712-SET-SCRIPT.
- 045700 IF COMBO EQUAL COMBO-ELEMENT ( FIND-SCRIPT )
- 045800 ADD ACR-DU TO TOTAL-ELEMENT ( FIND-SCRIPT )
- 045900 GO TO 712-SET-SCRIPT.
- 046000 GO TO 710-COMBO-ADD.
- 046100 712-SET-SCRIPT.
- 046200 MOVE ZEROS TO FIND-SCRIPT.
- 046300 714-EXIT.
- 046400 720-MOVE-TO-OUTPUT.
- 046500 IF FIRST-DATA-LINE
- 046600 MOVE SPACES TO DATA-LINE-2
- 046700 MOVE ALLOT-NUM TO ALLOT-NO-P
- 046800 MOVE SWA TO SWA-P
- 046900 MOVE ZERO TO FIRST-DATA-CONDITION
- 047000 MOVE SPACES TO WORK-PRINT
- 047100 PERFORM 260-WRITE-OUTPUT
- 047200 MOVE ALLOT-NUM TO SAVE-ALLOTMENT
- 047300 MOVE WS-PASTURE TO SAVE-PASTURE
- 047400 MOVE WS-PASTURE TO PASTURE-P
- 047500 ELSE MOVE SPACES TO DATA-LINE-2.
- 047600 IF LINE-COUNT GREATER 54
- 047700 MOVE ALLOT-NUM TO ALLOT-NO-P
- 047800 MOVE WS-PASTURE TO PASTURE-P
- 047900 MOVE SWA TO SWA-P.
- 048000 MOVE ACR-DU TO ACRES-P OF DATA-LINE-1.
- 048100 MOVE OWN-TYP TO OWNER-P.
- 048200 MOVE JURIS TO JURIS-P.
- 048300 MOVE IN-ADMIN TO ADMIN-P.
- 048400 MOVE LAND-TYP TO LAND-TYPE-P.
- 048500 MOVE MAP-SRC TO MAP-SPCE-P.
- 048600 MOVE IN-MTR-MER-CD TO MERID-P.
- 048700 MOVE MTR-TWSHP TO TWNSHP-P.
- 048800 MOVE IN-MTR-RNG TO RNGE-P.
- 048900 MOVE IN-SEC-SECT TO SECT-P.
- 049000 MOVE DATA-LINE-1 TO WORK-PRINT.
- 049100 ADD 1 TO DATA-PRINT-COUNT.
- 049200 PERFORM 260-WRITE-OUTPUT.
- 049300 900-WRAPUP.
- 049400 DISPLAY "INPUT RCDS= " READ-COUNT.
- 049500 DISPLAY "PAGES PRINTED= " PAGE-NO.
- 049600 DISPLAY "THIS IS A CHECK OF THE LARGEST TABLE SIZE"
- 049700 DISPLAY " REQUIRED FOR THIS RUN." "SUB= " SUB-CHK.
- 049800 PERFORM 500-SWA-TOTAL THRU 535-FINISH.
- 049900 FINISH DIC-DE.
- 050000 CLOSE INPUT-FILE PRINT-OUT.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES512Z.
- 000300* ACRES BY STRATUM COMPUTATION.
- 000400*
- 000500 AUTHOR. LEN SHEA.
- 000600 DATE-WRITTEN. 7 FEB 83.
- 000700 DATE-COMPILED.
- 000800 ENVIRONMENT DIVISION.
- 000900 CONFIGURATION SECTION.
- 001000 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001100 OBJECT-COMPUTER. LEVEL-66-ASCII.
- 001200 INPUT-OUTPUT SECTION.
- 001300 FILE-CONTROL.
- 001400 SELECT VA1Z-IN ASSIGN TO I1
- 001500 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001600 SELECT VB1Z-IN ASSIGN TO I2
- 001700 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001800 SELECT VAFILE-OUT ASSIGN TO D1
- 001900 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002000 DATA DIVISION.
- 002100 FILE SECTION.
- 002200 FD VA1Z-IN
- 002300 CODE-SET IS GBCD
- 002400 LABEL RECORDS ARE STANDARD.
- 002500 01 VA-IN-REC PIC X(90).
- 002600 FD VB1Z-IN
- 002700 CODE-SET IS GBCD
- 002800 LABEL RECORDS ARE STANDARD.
- 002900 01 VB-IN-REC PIC X(96).
- 003000 FD VAFILE-OUT
- 003100 CODE-SET IS GBCD
- 003200 LABEL RECORDS ARE STANDARD.
- 003300 01 VAOUT-REC PIC X(132).
- 003400 WORKING-STORAGE SECTION.
- 003500 77 VA-REC-IN-CNT PIC 9999 VALUE ZEROES.
- 003600 77 VB-REC-IN-CNT PIC 9999 VALUE ZEROES.
- 003700 77 VA-REC-OUT-CNT PIC 9999 VALUE ZEROES.
- 003800 77 VA-SUB PIC 999 VALUE ZEROES.
- 003900 77 VA-IN-EOF PIC XXX VALUE " NO".
- 004000 77 VB-IN-EOF PIC XXX VALUE " NO".
- 004100 77 VA-TBL-COUNT PIC 999 VALUE ZEROES.
- 004200 77 VAVB-SWA-MTCH PIC XXX VALUE " NO".
- 004300 77 VB-MATCH PIC XXX VALUE " NO".
- 004400 01 VA-ACRES-COMP PIC 9(5) VALUE ZEROES.
- 004500 01 VA-REC-IN.
- 004600 05 FILLER PIC X(48).
- 004700 05 VA-SWA PIC XXXX.
- 004800 05 FILLER PIC X(16).
- 004900 05 VA-ACRES PIC 9(5).
- 005000 05 FILLER PIC X(17).
- 005100 01 VB-REC-IN.
- 005200 05 FILLER PIC X(28).
- 005300 05 VB-SWA PIC XXXX.
- 005400 05 FILLER PIC XX.
- 005500 05 VB-SWA-PCT PIC 9V99.
- 005600 05 VB-SWA-PCT-R REDEFINES VB-SWA-PCT PIC X(03).
- 005700 05 VB-COPY-DATA1 PIC X(15).
- 005800 05 FILLER PIC X(6).
- 005900 05 VB-COPY-DATA2 PIC X(19).
- 006000 05 FILLER PIC X(19).
- 006100 01 VA-REC-OUT.
- 006200 05 VA-REC-DATA PIC X(90).
- 006300 05 ACRES-STRAT PIC 9(6) VALUE ZEROES.
- 006400 05 VB-RECV-DATA1 PIC X(15).
- 006500 05 VB-RECV-DATA2.
- 006600 07 VAB-SWA-PCT PIC X(03).
- 006700 07 FILLER PIC X(16).
- 006800 05 FILLER PIC X(02).
- 006900 01 VA-REC-TABLE.
- 007000 05 VA-REC-HOLD OCCURS 200.
- 007100 10 FILLER PIC X(48).
- 007200 10 VA-SWA-HOLD PIC XXXX.
- 007300 10 FILLER PIC X(16).
- 007400 10 VA-ACRES-HOLD PIC 9(5).
- 007500 10 FILLER PIC X(17).
- 007600 PROCEDURE DIVISION.
- 007700 0010-MAINLINE.
- 007800 OPEN INPUT VA1Z-IN, VB1Z-IN,
- 007900 OUTPUT VAFILE-OUT.
- 008000 PERFORM 0030-VA-READ.
- 008100 IF VA-IN-EOF = "YES"
- 008200 DISPLAY "VA FILE EMPTY"
- 008300 PERFORM 9999-ABORT.
- 008400 PERFORM 0040-VB-READ.
- 008500 IF VB-IN-EOF = "YES"
- 008600 DISPLAY "VB FILE EMPTY"
- 008700 PERFORM 9999-ABORT.
- 008800 PERFORM 0020-PROCESS THROUGH 0020-EXIT
- 008900 UNTIL VB-IN-EOF = "YES"
- 009000 AND VA-IN-EOF = "YES".
- 009100 PERFORM STOP-RUN-NOW.
- 009200 0020-PROCESS.
- 009300 IF VA-SWA < VB-SWA
- 009400 PERFORM 0060-VA-NOMATCH.
- 009500 IF VA-SWA > VB-SWA
- 009600 PERFORM 9998-ABORT.
- 009700 IF VA-SWA = VB-SWA
- 009800 MOVE "YES" TO VAVB-SWA-MTCH
- 009900 PERFORM 0070-VA-TABLE-BUILD THRU 0070-EXIT.
- 010000 PERFORM 0080-CALCULATE THROUGH 0080-EXIT.
- 010100 0020-EXIT.
- 010200 EXIT.
- 010300 0030-VA-READ.
- 010400 READ VA1Z-IN INTO VA-REC-IN
- 010500 AT END MOVE "YES" TO VA-IN-EOF.
- 010600 IF VA-IN-EOF = " NO"
- 010700 ADD 1 TO VA-REC-IN-CNT.
- 010800 0040-VB-READ.
- 010900 READ VB1Z-IN INTO VB-REC-IN
- 011000 AT END MOVE "YES" TO VB-IN-EOF.
- 011100 IF VB-IN-EOF = " NO"
- 011200 ADD 1 TO VB-REC-IN-CNT.
- 011300 0050-WRITE-OUT-REC.
- 011400 WRITE VAOUT-REC FROM VA-REC-OUT.
- 011500 ADD 1 TO VA-REC-OUT-CNT.
- 011600 0060-VA-NOMATCH.
- 011700 DISPLAY "NO VB RECORD TO MATCH THIS VA RECORD: ".
- 011800 DISPLAY VA-REC-IN.
- 011900 PERFORM STOP-RUN-NOW.
- 012000 0060-EXIT.
- 012100 EXIT.
- 012200 0070-VA-TABLE-BUILD.
- 012300 MOVE 1 TO VA-SUB.
- 012400 MOVE SPACES TO VA-REC-TABLE.
- 012500 0070-VA-DATA-MOVE.
- 012600 IF VA-SUB > 200 DISPLAY "INCREASE SIZE OF VA-REC-HOLD"
- 012700 CALL "ABOR".
- 012800 MOVE VA-REC-IN TO VA-REC-HOLD (VA-SUB).
- 012900 PERFORM 0030-VA-READ.
- 013000 IF VA-IN-EOF = "YES"
- 013100 MOVE " NO" TO VAVB-SWA-MTCH
- 013200 GO TO 0070-EXIT.
- 013300 IF VA-SWA = VB-SWA
- 013400 ADD 1 TO VA-SUB
- 013500 GO TO 0070-VA-DATA-MOVE
- 013600 ELSE
- 013700 MOVE " NO" TO VAVB-SWA-MTCH.
- 013800 0070-EXIT.
- 013900 EXIT.
- 014000 0080-CALCULATE.
- 014100 MOVE VA-SUB TO VA-TBL-COUNT.
- 014200 MOVE 1 TO VA-SUB.
- 014300 0080-MULTIPLY.
- 014400 MOVE VA-REC-HOLD (VA-SUB) TO VA-REC-OUT.
- 014500 MOVE VB-COPY-DATA1 TO VB-RECV-DATA1.
- 014600 MOVE VB-COPY-DATA2 TO VB-RECV-DATA2.
- 014700 MOVE VB-SWA-PCT-R TO VAB-SWA-PCT.
- 014800 COMPUTE ACRES-STRAT =
- 014900 (VA-ACRES-HOLD (VA-SUB) * VB-SWA-PCT * 10).
- 015000 PERFORM 0050-WRITE-OUT-REC.
- 015100 ADD 1 TO VA-SUB.
- 015200 IF VA-SUB > VA-TBL-COUNT
- 015300 PERFORM 0040-VB-READ
- 015400 MOVE 1 TO VA-SUB.
- 015500 IF VB-IN-EOF = "YES"
- 015600 GO TO 0080-EXIT.
- 015700 IF VA-SWA-HOLD (VA-SUB) = VB-SWA
- 015800 GO TO 0080-MULTIPLY.
- 015900 0080-EXIT.
- 016000 EXIT.
- 016100 9998-ABORT.
- 016200 DISPLAY "NO VA RECORD TO MATCH THIS VB RECORD: ".
- 016300 DISPLAY VB-REC-IN.
- 016400 PERFORM STOP-RUN-NOW.
- 016500 9999-ABORT.
- 016600 DISPLAY "VA OR VB FILE IS EMPTY, PROGRAM ABORTED."
- 016700 PERFORM STOP-RUN-NOW.
- 016800 STOP-RUN-NOW.
- 016900 DISPLAY "VA INPUT RECORDS: " VA-REC-IN-CNT.
- 017000 DISPLAY "VB INPUT RECORDS: " VB-REC-IN-CNT.
- 017100 DISPLAY "VA OUTPUT RECORDS: " VA-REC-OUT-CNT.
- 017200 CLOSE VA1Z-IN, VB1Z-IN, VAFILE-OUT.
- 017300 STOP RUN.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES515P.
- 000300* ALLOTMENT RANGE CONDITION INFORMATION REPORT, P01A.
- 000400*
- 000500 AUTHOR. ROSE DAVIS, RON BAKER.
- 000600 DATE-WRITTEN. 04/14/80.
- 000700*DATE-REVISED. MAR 1982.
- 000800 DATE-COMPILED.
- 000900 ENVIRONMENT DIVISION.
- 001000 CONFIGURATION SECTION.
- 001100 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001200 OBJECT-COMPUTER. LEVEL-66-ASCII, SEQUENCE IS EBCDIC.
- 001300 INPUT-OUTPUT SECTION.
- 001400 FILE-CONTROL.
- 001500 SELECT ACRE-STRATUM-FILE ASSIGN TO D1
- 001600 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001700 SELECT PRINT-FILE ASSIGN TO P1-PRINTER
- 001800 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001900 SELECT SORT-FILE ASSIGN TO S1.
- 002000 DATA DIVISION.
- 002100 SUB-SCHEMA SECTION.
- 002200 DB CODVAL2 WITHIN BLMDIC.
- 002300 FILE SECTION.
- 002400 FD ACRE-STRATUM-FILE
- 002500 CODE-SET IS GBCD
- 002600 LABEL RECORDS ARE STANDARD
- 002700 DATA RECORD IS ACRE-STRATUM-REC.
- 002800 01 ACRE-STRATUM-REC.
- 002900 03 REC-D1.
- 003000 05 REC-TYP-D1 PIC X(02).
- 003100 05 FMT-NUM-D1 PIC X.
- 003200 05 FMT-CD-D1 PIC X.
- 003300 03 ADM-UNIT-D1.
- 003400 05 ST-D1 PIC X(02).
- 003500 05 DIS-D1 PIC X(02).
- 003600 05 RA-D1 PIC X(02).
- 003700 05 PLU-D1 PIC X(02).
- 003800 03 ALLOT-D1.
- 003900 05 ALLOT-NUM-D1 PIC X(04).
- 004000 05 PAST-NUM-D1 PIC X(02).
- 004100 03 DATE-D1 PIC X(06).
- 004200 03 ACT-D1 PIC X(01).
- 004300 03 MAP-SRC-D1 PIC X(04).
- 004400 03 MTR-MER-CD-D1 PIC X(02).
- 004500 03 LINE-D1 PIC X(04).
- 004600 03 MTR-TWN-D1 PIC X(05).
- 004700 03 MTR-RNG-D1 PIC X(05).
- 004800 03 SEC-D1 PIC X(03).
- 004900 03 SWA-D1 PIC X(04).
- 005000 03 ALIQ-PART-D1 PIC X(16).
- 005100 03 ACRES-D1 PIC 9(05).
- 005200 03 OWNER-D1 PIC X(04).
- 005300 03 JURIS-D1 PIC X(04).
- 005400 03 MGT-ADM-D1 PIC X(04).
- 005500 03 LAND-TYP-D1 PIC X(04).
- 005600 03 FILLER PIC X(01).
- 005700 03 ACRES-STRATUM-D1 PIC 9(06).
- 005800 03 RNG-SITE-D1 PIC X(11).
- 005900 03 STRATUM-D1 PIC XXXX.
- 006000 03 GRP-D1.
- 006100 05 VEG-SUB-TYP-D1 PIC X(04).
- 006200 05 COND-CLS-D1 PIC X.
- 006300 05 PCT-SLP-D1 PIC XXX.
- 006400 05 ASPT-D1 PIC XX.
- 006500 05 L-FORM-D1 PIC XXX.
- 006600 05 SOIL-PHASE-D1 PIC X(6).
- 006700 03 FILLER PIC X(2).
- 006800 FD PRINT-FILE
- 006900 CODE-SET IS GBCD
- 007000 LABEL RECORDS ARE STANDARD
- 007100 DATA RECORD IS PRINT-REC.
- 007200 01 PRINT-REC PIC X(132).
- 007300 SD SORT-FILE
- 007400 DATA RECORDS ARE SORT-REC.
- 007500 01 SORT-REC.
- 007600 05 FILLER PIC X(22).
- 007700 05 SORT-KEY PIC X(7).
- 007800 WORKING-STORAGE SECTION.
- 007900 77 FLAGG1 PIC 9 VALUE 0.
- 008000 77 PAGECT PIC 9(5) VALUE ZEROS.
- 008100 77 LINECT PIC 99 VALUE ZEROS.
- 008200 77 10OT PIC 9(6)V9.
- 008300 77 11OT PIC 9(6)V9.
- 008400 77 12OT PIC 9(6)V9.
- 008500 77 13OT PIC 9(7)V9.
- 008600 77 14OT PIC 9(7)V9.
- 008700 77 15OT PIC 9(7)V9.
- 008800 77 16OT PIC 9(7)V9.
- 008900 77 17OT PIC 9(7)V9.
- 009000 77 18OT PIC 9(7)V9.
- 009100 77 20OT PIC 9(7)V9.
- 009200 77 21OT PIC 9(7)V9.
- 009300 77 22OT PIC 9(7)V9.
- 009400 77 24OT PIC 9(7)V9.
- 009500 77 25OT PIC 9(7)V9.
- 009600 77 26OT PIC 9(7)V9.
- 009700 77 28OT PIC 9(7)V9.
- 009800 77 29OT PIC 9(7)V9.
- 009900 77 30OT PIC 9(7)V9.
- 010000 77 32OT PIC 9(7)V9.
- 010100 77 33OT PIC 9(7)V9.
- 010200 77 34OT PIC 9(7)V9.
- 010300 77 32OTX PIC 9(7)V9.
- 010400 77 33OTX PIC 9(7)V9.
- 010500 77 34OTX PIC 9(7)V9.
- 010600 77 32OTXX PIC 9(7)V9.
- 010700 77 33OTXX PIC 9(7)V9.
- 010800 77 34OTXX PIC 9(7)V9.
- 010900 77 CNT-IN PIC 9(8) VALUE ZERO.
- 011000 77 DET-CNT PIC 9(8) VALUE ZERO.
- 011100 77 TEST-CNT PIC 9(8) VALUE 99999999.
- 011200 01 HOLD-AREA.
- 011300 03 ADST-DIST-RA-PLU-CDS-H.
- 011400 05 ADSTDSRA-CD-H.
- 011500 07 ADST-CD-H PIC XX.
- 011600 07 DIST-CD-H PIC XX.
- 011700 07 RA-CD-H PIC XX.
- 011800 05 PLU-CD-H PIC XX.
- 011900 03 CE-CD-EXPL-LIN-H.
- 012000 05 DIST-NAM-H PIC X(12).
- 012100 05 RA-NAM-H PIC X(13).
- 012200 05 PLU-NAM-H PIC X(15).
- 012300 03 CT-FUNC-NAM-H.
- 012400 05 ST-NAM-H PIC X(10).
- 012500 05 FILLER PIC X(14).
- 012600 01 ALOT-H PIC X(4).
- 012700 01 31H PIC X(6).
- 012800 01 RS-S-VST-CC-H PIC X(20).
- 012900 01 ACRE-STRATUM-REC-HLD.
- 013000 05 REC-TYPE-W PIC X(4).
- 013100 05 SDRP-W.
- 013200 07 SDR-W.
- 013300 09 SD-W.
- 013400 11 ST-W PIC XX.
- 013500 11 DS-W PIC XX.
- 013600 09 RA-W PIC XX.
- 013700 07 PU-W PIC XX.
- 013800 05 ALLOT-W.
- 013900 07 ALOT-W PIC X(04).
- 014000 07 PAST-NUM-W PIC X(02).
- 014100 05 FILLER PIC X(30).
- 014200 05 SWA-W PIC X(04).
- 014300 05 FILLER PIC X(16).
- 014400 05 ACRES-SWA-W PIC 9(05).
- 014500 05 OWNER-W PIC X(04).
- 014600 05 JURIS-W PIC X(04).
- 014700 05 MGT-ADM-W PIC X(04).
- 014800 05 LAND-TYP-W PIC X(04).
- 014900 05 FILLER PIC X.
- 015000 05 ACRES-W PIC X(06).
- 015100 05 ACRES-W-RD REDEFINES ACRES-W PIC 9(05)V9.
- 015200 05 RS-S-VST-CC.
- 015300 10 RNG-SITE-W.
- 015400 15 RNG-SITE-W1 PIC X(5).
- 015500 15 RNG-SITE-W2 PIC X(2).
- 015600 15 RNG-SITE-W3 PIC X(4).
- 015700 10 STRAT-W PIC X(4).
- 015800 10 VEG-SUB-TYP-W PIC X(4).
- 015900 10 COND-CLASS-W PIC X.
- 016000 05 PCT-SLP-W PIC XXX.
- 016100 05 ASPT-W PIC XX.
- 016200 05 L-FORM-W PIC XXX.
- 016300 05 SOIL-PHASE-W PIC X(6).
- 016400 05 FILLER PIC X(2).
- 016500 01 PW1 PIC 9V9999.
- 016600 01 PW1X REDEFINES PW1 PIC 999V99.
- 016700 01 DATE-IN.
- 016800 05 YY PIC XX.
- 016900 05 MM PIC XX.
- 017000 05 DD PIC XX.
- 017100 01 COND-CLASSW.
- 017200 05 COND-CLASS-CCW PIC X.
- 017300 05 FILLER PIC X(5) VALUE SPACES.
- 017400 05 40OT PIC 9(7)V9.
- 017500 05 41OT PIC 9(7)V9.
- 017600 05 KEY-2.
- 017700 10 KEY-CCW PIC X VALUE "2".
- 017800 10 COND-CLASS-KEY-CCW PIC X.
- 017900 10 FILLER PIC X(5) VALUE SPACES.
- 018000 01 SOIL-SERIESW.
- 018100 05 SOIL-SER-SSW PIC X(6).
- 018200 05 FILLER PIC X VALUE ZERO.
- 018300 05 44OT PIC 9(6)V9.
- 018400 05 FILLER PIC X VALUE ZERO.
- 018500 05 45OT PIC 9(6)V9.
- 018600 05 KEY-3.
- 018700 10 KEY-SS PIC X VALUE "3".
- 018800 10 SOIL-SER-KEY-SSW PIC X(6).
- 018900 01 STRATUMW.
- 019000 05 STRAT-SW PIC X(4).
- 019100 05 FILLER PIC XX VALUE SPACE.
- 019200 05 36OT PIC 9(7)V9.
- 019300 05 37OT PIC 9(7)V9.
- 019400 05 KEY-1.
- 019500 10 KEY-STR PIC X VALUE "1".
- 019600 10 STRAT-KEY-SW PIC X(4).
- 019700 10 FILLER PIC XX.
- 019800 01 HD1.
- 019900 03 FILLER PIC X(13) VALUE "REPORT DATE: ".
- 020000 03 HD-MM PIC XX.
- 020100 03 FILLER PIC X VALUE "/".
- 020200 03 HD-DD PIC XX.
- 020300 03 FILLER PIC X VALUE "/".
- 020400 03 HD-YY PIC XX.
- 020500 03 FILLER PIC X(28) VALUE SPACES.
- 020600 03 FILLER PIC X(23) VALUE "U.S.D.I. BUREAU OF LAND".
- 020700 03 FILLER PIC X(11) VALUE " MANAGEMENT".
- 020800 03 FILLER PIC X(22) VALUE SPACES.
- 020900 03 FILLER PIC X(15) VALUE "PCN: P01A ".
- 021000 03 FILLER PIC X(6) VALUE " PAGE ".
- 021100 03 HDR-PG PIC ZZ,ZZ9.
- 021200 01 HD3.
- 021300 05 FILLER PIC X(19) VALUE
- 021400- " STATE ".
- 021500 05 HD4-ST PIC X(35) VALUE
- 021600- "WYOMING ".
- 021700 05 FILLER PIC X(25) VALUE
- 021800- "ECOLOGICAL SITE INVENTORY".
- 021900 05 FILLER PIC X(38) VALUE SPACES.
- 022000 05 FILLER PIC X(06)
- 022100 VALUE SPACE.
- 022200 05 FILLER PIC X(09)
- 022300 VALUE SPACE.
- 022400 01 HD4.
- 022500 05 FILLER PIC X(19) VALUE
- 022600- " DISTRICT ".
- 022700 05 HD4-DS PIC X(20) VALUE "ROCK SPRINGS".
- 022800 05 FILLER PIC X(93) VALUE SPACES.
- 022900 01 HD5.
- 023000 05 FILLER PIC X(19) VALUE " RESOURCE AREA ".
- 023100 05 HD5-RA PIC X(20) VALUE "SALT WELLS ".
- 023200 05 FILLER PIC X(8) VALUE SPACES.
- 023300 05 HD5-NAME PIC X(37) VALUE
- 023400 "ALLOTMENT RANGE CONDITION INFORMATION".
- 023500 05 FILLER PIC X(48) VALUE SPACES.
- 023600 01 HD6.
- 023700 05 FILLER PIC X(14) VALUE " ALLOTMENT ".
- 023800 05 HD6-ALOT PIC X(4).
- 023900 05 FILLER PIC X(114) VALUE SPACES.
- 024000 01 HD7.
- 024100 05 FILLER PIC X(94) VALUE SPACES.
- 024200 05 FILLER PIC X(29) VALUE
- 024300 "-------STRATUM ACREAGE------".
- 024400 05 FILLER PIC X(9) VALUE SPACES.
- 024500 01 HD8.
- 024600 05 FILLER PIC X(43) VALUE SPACES.
- 024700 05 FILLER PIC X(42) VALUE
- 024800 "VEGETAL CONDITION PHASE OF".
- 024900 05 FILLER PIC X(47) VALUE SPACES.
- 025000 01 HD9.
- 025100 05 FILLER PIC X(16) VALUE " STRATUM".
- 025200 05 FILLER PIC X(18) VALUE " RANGE SITE".
- 025300 05 FILLER PIC X(16) VALUE " SUB-TYPE".
- 025400 05 FILLER PIC X(15) VALUE " CLASS".
- 025500 05 FILLER PIC X(21) VALUE " SOIL SERIES".
- 025600 05 FILLER PIC X(11) VALUE " BLM".
- 025700 05 FILLER PIC X(14) VALUE " OTHER".
- 025800 05 FILLER PIC X(21) VALUE " TOTAL ".
- 025900 01 HD10.
- 026000 05 FILLER PIC X(82) VALUE SPACES.
- 026100 05 FILLER PIC X(33) VALUE
- 026200- "ALLOTMENT RANGE CONDITION SUMMARY".
- 026300 05 FILLER PIC X(17) VALUE SPACES.
- 026400 01 DATA1.
- 026500 05 FILLER PIC X(10) VALUE SPACES.
- 026600 05 STRAT-P PIC X(4).
- 026700 05 FILLER PIC X(10) VALUE SPACES.
- 026800 05 RNG-SITE-P PIC X(11).
- 026900 05 FILLER PIC X(9) VALUE SPACES.
- 027000 05 VEG-SUB-TYP-P PIC X(4).
- 027100 05 FILLER PIC X(14) VALUE SPACES.
- 027200 05 COND-CLASS-P PIC X.
- 027300 05 FILLER PIC X(14) VALUE SPACES.
- 027400 05 SOIL-SER-P PIC X(6).
- 027500 05 FILLER PIC X(5) VALUE SPACES.
- 027600 05 10PT PIC ZZZ,ZZZ.9.
- 027700 05 FILLER PIC X(5) VALUE SPACES.
- 027800 05 11PT PIC ZZZ,ZZZ.9.
- 027900 05 FILLER PIC X(5) VALUE SPACES.
- 028000 05 12PT PIC ZZZ,ZZZ.9.
- 028100 05 FILLER PIC X(7) VALUE SPACES.
- 028200 01 DATA2.
- 028300 05 FILLER PIC X(60) VALUE SPACES.
- 028400 05 FILLER PIC X(26) VALUE
- 028500 "STRATUM SUB-TOTAL ".
- 028600 05 13PT PIC Z,ZZZ,ZZZ.9.
- 028700 05 FILLER PIC X(3) VALUE SPACES.
- 028800 05 14PT PIC Z,ZZZ,ZZZ.9.
- 028900 05 FILLER PIC X(3) VALUE SPACES.
- 029000 05 15PT PIC Z,ZZZ,ZZZ.9.
- 029100 05 FILLER PIC X(7) VALUE SPACES.
- 029200 01 DATA3.
- 029300 05 FILLER PIC X(60) VALUE SPACES.
- 029400 05 FILLER PIC X(26) VALUE
- 029500 "ALLOTMENT ACREAGE TOTAL ".
- 029600 05 16PT PIC Z,ZZZ,ZZZ.9.
- 029700 05 FILLER PIC X(3) VALUE SPACES.
- 029800 05 17PT PIC Z,ZZZ,ZZZ.9.
- 029900 05 FILLER PIC X(3) VALUE SPACES.
- 030000 05 18PT PIC Z,ZZZ,ZZZ.9.
- 030100 05 FILLER PIC X(7) VALUE SPACES.
- 030200 01 DATA4.
- 030300 05 FILLER PIC X(70) VALUE SPACES.
- 030400 05 19-31PT PIC X(10).
- 030500 05 FILLER PIC X(5) VALUE SPACES.
- 030600 05 20-32PT PIC Z,ZZZ,ZZZ.9.
- 030700 05 FILLER PIC X(3) VALUE SPACES.
- 030800 05 21-33PT PIC Z,ZZZ,ZZZ.9.
- 030900 05 FILLER PIC X(3) VALUE SPACES.
- 031000 05 22-34PT PIC Z,ZZZ,ZZZ.9.
- 031100 05 FILLER PIC X VALUE SPACE.
- 031200 05 PERCENT PIC ZZZ.99.
- 031300 05 FILLER PIC X VALUE "%".
- 031400******WORKING AREA FOR OUTPUT********
- 031500 01 KEYR1H PIC 9 VALUE ZERO.
- 031600 01 36RH PIC 9(8)V9 VALUE ZEROS.
- 031700 01 37RH PIC 9(8)V9 VALUE ZEROS.
- 031800 01 38RH PIC 9(8)V9.
- 031900 01 36RHT PIC 9(9)V9 VALUE ZEROS.
- 032000 01 37RHT PIC 9(9)V9 VALUE ZEROS.
- 032100 01 38RHT PIC 9(9)V9.
- 032200 01 35-43RH PIC X(6).
- 032300 01 HOLD-SORT-REC.
- 032400 05 35-43R.
- 032500 10 39R PIC X.
- 032600 10 FILLER PIC X(5).
- 032700 05 36R PIC 9(7)V9.
- 032800 05 37R PIC 9(7)V9.
- 032900 05 KEYR.
- 033000 10 KEYR1 PIC 9.
- 033100 10 KEYR2 PIC X(6).
- 033200 01 35R.
- 033300 05 35R1 PIC X(3) VALUE SPACES.
- 033400 05 35R2 PIC X(6).
- 033500 05 35R3 PIC X(1) VALUE SPACES.
- 033600 01 43R.
- 033700 05 43R1 PIC X(2) VALUE SPACES.
- 033800 05 43R2 PIC X(6).
- 033900 05 43R3 PIC X(2) VALUE SPACES.
- 034000 01 HD1R.
- 034100 05 FILLER PIC X(54) VALUE SPACES.
- 034200 05 HD1-NAME PIC X(23) VALUE " STRATUM SUMMARY ".
- 034300 05 FILLER PIC X(55) VALUE SPACES.
- 034400 01 HD2R.
- 034500 05 FILLER PIC X(77) VALUE SPACES.
- 034600 05 FILLER PIC X(42) VALUE
- 034700- "------------------ACREAGE-----------------".
- 034800 05 FILLER PIC X(13) VALUE SPACES.
- 034900 01 HD3R.
- 035000 05 FILLER PIC X(26) VALUE SPACES.
- 035100 05 HD3-NAME PIC X(15) VALUE " STRATUM ".
- 035200 05 FILLER PIC X(39) VALUE SPACES.
- 035300 05 FILLER PIC X(3) VALUE "BLM".
- 035400 05 FILLER PIC X(13) VALUE SPACES.
- 035500 05 FILLER PIC X(5) VALUE "OTHER".
- 035600 05 FILLER PIC X(14) VALUE SPACES.
- 035700 05 FILLER PIC X(5) VALUE "TOTAL".
- 035800 05 FILLER PIC X(15) VALUE SPACES.
- 035900 01 HD4R.
- 036000 05 FILLER PIC X(28) VALUE SPACES.
- 036100 05 HD4-NAME PIC X(10).
- 036200 05 FILLER PIC X(33) VALUE SPACES.
- 036300 05 36-44R PIC ZZ,ZZZ,ZZZ.9.
- 036400 05 FILLER PIC X(6) VALUE SPACES.
- 036500 05 37-45R PIC ZZ,ZZZ,ZZZ.9.
- 036600 05 FILLER PIC X(7) VALUE SPACES.
- 036700 05 38-46R PIC ZZ,ZZZ,ZZZ.9.
- 036800 05 FILLER PIC X(12) VALUE SPACES.
- 036900 01 HD4RX.
- 037000 05 FILLER PIC X(28) VALUE SPACES.
- 037100 05 HD4-NAMEX PIC X(10).
- 037200 05 FILLER PIC X(33) VALUE SPACES.
- 037300 05 36-44RX PIC ZZ,ZZZ,ZZZ.9.
- 037400 05 FILLER PIC X(6) VALUE SPACES.
- 037500 05 37-45RX PIC ZZ,ZZZ,ZZZ.9.
- 037600 05 FILLER PIC X(7) VALUE SPACES.
- 037700 05 38-46RX PIC ZZ,ZZZ,ZZZ.9.
- 037800 05 FILLER PIC X(3) VALUE SPACES.
- 037900 05 PERCENTS PIC ZZZ.99.
- 038000 05 FILLER PIC X VALUE "%".
- 038100 05 FILLER PIC X(2) VALUE SPACES.
- 038200 01 HD5R.
- 038300 05 FILLER PIC X(23) VALUE SPACES.
- 038400 05 FILLER PIC X(15) VALUE "RESOURCE TOTALS".
- 038500 05 FILLER PIC X(32) VALUE SPACES.
- 038600 05 36-44RT PIC ZZZ,ZZZ,ZZZ.9.
- 038700 05 FILLER PIC X(5) VALUE SPACES.
- 038800 05 37-45RT PIC ZZZ,ZZZ,ZZZ.9.
- 038900 05 FILLER PIC X(6) VALUE SPACES.
- 039000 05 38-46RT PIC ZZZ,ZZZ,ZZZ.9.
- 039100 05 FILLER PIC X(12) VALUE SPACES.
- 039200 01 HD1RX.
- 039300 05 FILLER PIC X(19) VALUE " RESOURCE AREA ".
- 039400 05 HD1RX-RA PIC X(20) VALUE "SALT WELLS ".
- 039500 05 FILLER PIC X(15) VALUE SPACES.
- 039600 05 HD1RX-NAME PIC X(23) VALUE " STRATUM SUMMARY ".
- 039700 05 FILLER PIC X(39) VALUE SPACES.
- 039800 05 FILLER PIC X(8) VALUE "PAGE NO ".
- 039900 05 PG-NOX PIC ZZZZ9.
- 040000 05 FILLER PIC X(3) VALUE SPACES.
- 040100 01 ST-NAM-HLD.
- 040200 03 ST-NAME PIC X(10).
- 040300 03 FILLER PIC X(14).
- 040400 01 DRP-NAM-HLD.
- 040500 03 DS-NAME PIC X(10).
- 040600 03 FILLER PIC XX.
- 040700 03 RA-NAME PIC X(12).
- 040800 03 FILLER PIC X.
- 040900 03 PU-NAME PIC X(15).
- 041000 01 FILE-STATUS.
- 041100 03 MAJOR-STATUS PIC X.
- 041200 03 MINOR-STATUS PIC X.
- 041300 COPY DBSTATUS IN TPCOBOLIB.
- 041400 PROCEDURE DIVISION.
- 041500 SORT-STATEMENT SECTION.
- 041600 SORT-STATEMENT-PARA.
- 041700 SORT SORT-FILE ON ASCENDING KEY SORT-KEY,
- 041800 INPUT PROCEDURE IS 100-INPUT,
- 041900 OUTPUT PROCEDURE IS 600-OUTPUT.
- 042000 FINISH DIC-DE.
- 042100 STOP RUN.
- 042200 100-INPUT SECTION.
- 042300 110-INPUT.
- 042400 OPEN INPUT ACRE-STRATUM-FILE
- 042500 OUTPUT PRINT-FILE.
- 042600 READY DIC-DE.
- 042700 ACCEPT DATE-IN FROM DATE.
- 042800 MOVE YY TO HD-YY.
- 042900 MOVE MM TO HD-MM.
- 043000 MOVE DD TO HD-DD.
- 043100 120-READ1.
- 043200 READ ACRE-STRATUM-FILE AT END GO TO 130-READ2.
- 043300* DISPLAY ACRE-STRATUM-REC.
- 043400 MOVE ACRE-STRATUM-REC TO ACRE-STRATUM-REC-HLD.
- 043500 MOVE SDRP-W TO ADST-DIST-RA-PLU-CDS-H.
- 043600 PERFORM 590-DB-HDR THRU 590-EXIT.
- 043700 MOVE ALOT-W TO ALOT-H, HD6-ALOT.
- 043800 MOVE RS-S-VST-CC TO RS-S-VST-CC-H.
- 043900 MOVE RNG-SITE-W TO RNG-SITE-P.
- 044000 MOVE STRAT-W TO STRAT-P.
- 044100 MOVE VEG-SUB-TYP-W TO VEG-SUB-TYP-P.
- 044200 MOVE COND-CLASS-W TO COND-CLASS-P.
- 044300* IF RA-W = "48" MOVE "VALLEY " TO HD5-RA, HD1RX-RA
- 044400* ELSE IF RA-W = "58" MOVE "PHILLIPS" TO HD5-RA, HD1RX-RA
- 044500* ELSE IF RA-W = "68" MOVE "HAVRE " TO HD5-RA, HD1RX-RA
- 044600* ELSE DISPLAY "BAD RESOURCE AREA" SPACE ACRE-STRATUM-REC
- 044700* GO TO 120-READ1.
- 044800 EXAMINE ACRES-W REPLACING ALL SPACES BY ZEROS.
- 044900* IF RNG-SITE-W2 = "27" MOVE "C" TO COND-CLASS-W.
- 045000 IF SOIL-PHASE-W = "000110" MOVE "U" TO COND-CLASS-W.
- 045100 MOVE ZEROS TO 13OT, 14OT, 16OT, 17OT, 20OT, 21OT,
- 045200 24OT, 25OT, 28OT, 29OT, 32OT, 33OT, 36OT, 37OT,
- 045300 40OT, 41OT, 44OT, 45OT, 32OTX, 33OTX, 32OTXX, 33OTXX.
- 045400 PERFORM 310-ACREAGE THRU 310-ACREAGE-EXIT.
- 045500 PERFORM 400-HDGS1 THRU 400-HDGS1-EXIT.
- 045600 PERFORM 400-HDGS1A THRU 400-HDGS1A-EXIT.
- 045700 130-READ2.
- 045800 READ ACRE-STRATUM-FILE AT END GO TO 510-CLOSE-INPUT.
- 045900 ADD 1 TO CNT-IN.
- 046000 IF CNT-IN > TEST-CNT GO TO 510-CLOSE-INPUT.
- 046100* DISPLAY ACRE-STRATUM-REC.
- 046200 MOVE ACRE-STRATUM-REC TO ACRE-STRATUM-REC-HLD.
- 046300 EXAMINE ACRES-W REPLACING ALL SPACES BY ZEROS.
- 046400* IF RNG-SITE-W2 = "27" MOVE "C" TO COND-CLASS-W.
- 046500 IF SOIL-PHASE-W = "000110" MOVE "U" TO COND-CLASS-W.
- 046600 IF ALOT-W = HD6-ALOT
- 046700 PERFORM 150-P1 THRU 150-P1-EXIT
- 046800 GO TO 130-READ2.
- 046900 PERFORM 320-SOIL-SERIES THRU 320-SOIL-SER-EXIT.
- 047000 PERFORM 300-COND-CK THRU 300-CC-EXIT.
- 047100 PERFORM 330-STRATUM-CHG THRU 330-SC-EXIT.
- 047200 PERFORM 340-ALLOTMENT-CHG THRU 340-AC-EXIT.
- 047300 PERFORM 400-HDGS1 THRU 400-HDGS1-EXIT.
- 047400 PERFORM 400-HDGS1A THRU 400-HDGS1A-EXIT.
- 047500 PERFORM 310-ACREAGE THRU 310-ACREAGE-EXIT.
- 047600 GO TO 130-READ2.
- 047700 150-P1.
- 047800 IF (RS-S-VST-CC = RS-S-VST-CC-H) AND (SOIL-PHASE-W = 31H)
- 047900 PERFORM 200-OWNR-CK THRU 200-OC-EXIT
- 048000 GO TO 150-P1-EXIT.
- 048100 IF (RS-S-VST-CC = RS-S-VST-CC-H) AND (SOIL-PHASE-W NOT = 31H)
- 048200 PERFORM 320-SOIL-SERIES THRU 320-SOIL-SER-EXIT
- 048300 PERFORM 300-COND-CK THRU 300-CC-EXIT
- 048400 PERFORM 310-ACREAGE THRU 310-ACREAGE-EXIT
- 048500 GO TO 150-P1-EXIT.
- 048600 PERFORM 320-SOIL-SERIES THRU 320-SOIL-SER-EXIT.
- 048700 PERFORM 300-COND-CK THRU 300-CC-EXIT.
- 048800 PERFORM 330-STRATUM-CHG THRU 330-SC-EXIT.
- 048900 PERFORM 310-ACREAGE THRU 310-ACREAGE-EXIT.
- 049000 150-P1-EXIT. EXIT.
- 049100 200-OWNR-CK.
- 049200 IF JURIS-W = "BLM" ADD ACRES-W-RD TO 10OT
- 049300 ELSE ADD ACRES-W-RD TO 11OT.
- 049400* DISPLAY "10OT= " 10OT.
- 049500 200-OC-EXIT. EXIT.
- 049600 300-COND-CK.
- 049700 IF COND-CLASS-P = "E"
- 049800 ADD 10OT TO 20OT ADD 11OT TO 21OT
- 049900 ELSE IF COND-CLASS-P = "G"
- 050000 ADD 10OT TO 24OT ADD 11OT TO 25OT
- 050100 ELSE IF COND-CLASS-P = "F"
- 050200 ADD 10OT TO 28OT ADD 11OT TO 29OT
- 050300 ELSE IF COND-CLASS-P = "P"
- 050400 ADD 10OT TO 32OT ADD 11OT TO 33OT
- 050500 ELSE IF COND-CLASS-P = "C"
- 050600 ADD 10OT TO 32OTXX ADD 11OT TO 33OTXX
- 050700 ELSE IF COND-CLASS-P = "U"
- 050800 ADD 10OT TO 32OTX ADD 11OT TO 33OTX
- 050900 ELSE ADD 10OT TO 32OTX ADD 11OT TO 33OTX.
- 051000 300-CC-EXIT. EXIT.
- 051100 310-ACREAGE.
- 051200 MOVE SOIL-PHASE-W TO 31H, SOIL-SER-P.
- 051300 IF JURIS-W NOT = "BLM"
- 051400 MOVE ACRES-W-RD TO 11OT
- 051500 MOVE ZEROS TO 10OT
- 051600 ELSE MOVE ACRES-W-RD TO 10OT
- 051700 MOVE ZEROS TO 11OT.
- 051800 310-ACREAGE-EXIT. EXIT.
- 051900 320-SOIL-SERIES.
- 052000 IF SDR-W NOT = ADSTDSRA-CD-H
- 052100 MOVE SDRP-W TO ADST-DIST-RA-PLU-CDS-H
- 052200 PERFORM 590-DB-HDR THRU 590-EXIT.
- 052300 IF LINECT > 53
- 052400 PERFORM 400-HDGS1 THRU 400-HDGS1-EXIT
- 052500 PERFORM 400-HDGS1A THRU 400-HDGS1A-EXIT.
- 052600 ADD 10OT, 11OT GIVING 12OT.
- 052700 MOVE 10OT TO 10PT.
- 052800 MOVE 11OT TO 11PT.
- 052900 MOVE 12OT TO 12PT.
- 053000 MOVE DATA1 TO PRINT-REC.
- 053100 WRITE PRINT-REC.
- 053200 ADD 1 TO LINECT.
- 053300 ADD 1 TO DET-CNT.
- 053400 MOVE SOIL-SER-P TO SOIL-SER-SSW, SOIL-SER-KEY-SSW.
- 053500 MOVE 10OT TO 44OT.
- 053600 MOVE 11OT TO 45OT.
- 053700 RELEASE SORT-REC FROM SOIL-SERIESW.
- 053800 ADD 10OT TO 13OT.
- 053900 ADD 11OT TO 14OT.
- 054000 320-SOIL-SER-EXIT. EXIT.
- 054100 330-STRATUM-CHG.
- 054200 ADD 13OT, 14OT GIVING 15OT.
- 054300 MOVE 13OT TO 13PT.
- 054400 MOVE 14OT TO 14PT.
- 054500 MOVE 15OT TO 15PT.
- 054600 IF DET-CNT = 1
- 054700 GO TO PASS-STRAT-TOT.
- 054800 IF LINECT > 53
- 054900 PERFORM 400-HDGS1 THRU 400-HDGS1-EXIT.
- 055000 MOVE DATA2 TO PRINT-REC.
- 055100 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 055200 MOVE SPACES TO PRINT-REC.
- 055300 WRITE PRINT-REC.
- 055400 ADD 3 TO LINECT.
- 055500 PASS-STRAT-TOT.
- 055600 MOVE ZERO TO DET-CNT.
- 055700 ADD 13OT TO 16OT.
- 055800 ADD 14OT TO 17OT.
- 055900 MOVE STRAT-P TO STRAT-SW, STRAT-KEY-SW.
- 056000 MOVE 13OT TO 36OT.
- 056100 MOVE 14OT TO 37OT.
- 056200 RELEASE SORT-REC FROM STRATUMW.
- 056300 MOVE ZEROS TO 13OT, 14OT.
- 056400 MOVE RS-S-VST-CC TO RS-S-VST-CC-H.
- 056500 MOVE RNG-SITE-W TO RNG-SITE-P.
- 056600 MOVE STRAT-W TO STRAT-P.
- 056700 MOVE VEG-SUB-TYP-W TO VEG-SUB-TYP-P.
- 056800 MOVE COND-CLASS-W TO COND-CLASS-P.
- 056900 330-SC-EXIT. EXIT.
- 057000 340-ALLOTMENT-CHG.
- 057100 IF LINECT > 53
- 057200 PERFORM 400-HDGS1 THRU 400-HDGS1-EXIT.
- 057300 ADD 16OT, 17OT GIVING 18OT.
- 057400 MOVE 16OT TO 16PT.
- 057500 MOVE 17OT TO 17PT.
- 057600 MOVE 18OT TO 18PT.
- 057700 MOVE DATA3 TO PRINT-REC
- 057800 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 057900 ADD 2 TO LINECT.
- 058000 ADD 20OT, 21OT GIVING 22OT.
- 058100 ADD 24OT, 25OT GIVING 26OT.
- 058200 ADD 28OT, 29OT GIVING 30OT.
- 058300 ADD 32OT, 33OT GIVING 34OT.
- 058400 ADD 32OTX, 33OTX GIVING 34OTX.
- 058500 ADD 32OTXX, 33OTXX GIVING 34OTXX.
- 058600 IF LINECT > 39
- 058700 PERFORM 400-HDGS1 THRU 400-HDGS1-EXIT.
- 058800 MOVE HD10 TO PRINT-REC.
- 058900 WRITE PRINT-REC AFTER 2 LINES.
- 059000 MOVE "EXCELLENT " TO 19-31PT.
- 059100 MOVE 20OT TO 20-32PT.
- 059200 MOVE 21OT TO 21-33PT.
- 059300 MOVE 22OT TO 22-34PT.
- 059400 DIVIDE 18OT INTO 22OT GIVING PW1 ROUNDED.
- 059500 PERFORM 500-CP THRU 500-CP-EXIT.
- 059600 MOVE DATA4 TO PRINT-REC.
- 059700 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 059800 MOVE "GOOD " TO 19-31PT.
- 059900 MOVE 24OT TO 20-32PT.
- 060000 MOVE 25OT TO 21-33PT.
- 060100 MOVE 26OT TO 22-34PT.
- 060200 DIVIDE 18OT INTO 26OT GIVING PW1 ROUNDED.
- 060300 PERFORM 500-CP THRU 500-CP-EXIT.
- 060400 MOVE DATA4 TO PRINT-REC.
- 060500 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 060600 MOVE "FAIR " TO 19-31PT.
- 060700 MOVE 28OT TO 20-32PT.
- 060800 MOVE 29OT TO 21-33PT.
- 060900 MOVE 30OT TO 22-34PT.
- 061000 DIVIDE 18OT INTO 30OT GIVING PW1 ROUNDED.
- 061100 PERFORM 500-CP THRU 500-CP-EXIT.
- 061200 MOVE DATA4 TO PRINT-REC.
- 061300 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 061400 MOVE "POOR " TO 19-31PT.
- 061500 MOVE 32OT TO 20-32PT.
- 061600 MOVE 33OT TO 21-33PT.
- 061700 MOVE 34OT TO 22-34PT.
- 061800 DIVIDE 18OT INTO 34OT GIVING PW1 ROUNDED.
- 061900 PERFORM 500-CP THRU 500-CP-EXIT.
- 062000 MOVE DATA4 TO PRINT-REC.
- 062100 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 062200 MOVE "CROPLAND " TO 19-31PT.
- 062300 MOVE 32OTXX TO 20-32PT.
- 062400 MOVE 33OTXX TO 21-33PT.
- 062500 MOVE 34OTXX TO 22-34PT.
- 062600 DIVIDE 18OT INTO 34OTXX GIVING PW1 ROUNDED.
- 062700 PERFORM 500-CP THRU 500-CP-EXIT.
- 062800 MOVE DATA4 TO PRINT-REC.
- 062900 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 063000 MOVE "UNSUITABLE" TO 19-31PT.
- 063100 MOVE 32OTX TO 20-32PT.
- 063200 MOVE 33OTX TO 21-33PT.
- 063300 MOVE 34OTX TO 22-34PT.
- 063400 DIVIDE 18OT INTO 34OTX GIVING PW1 ROUNDED.
- 063500 PERFORM 500-CP THRU 500-CP-EXIT.
- 063600 MOVE DATA4 TO PRINT-REC.
- 063700 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 063800 MOVE "E" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
- 063900 MOVE 20OT TO 40OT.
- 064000 MOVE 21OT TO 41OT.
- 064100 RELEASE SORT-REC FROM COND-CLASSW.
- 064200 MOVE "G" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
- 064300 MOVE 24OT TO 40OT.
- 064400 MOVE 25OT TO 41OT.
- 064500 RELEASE SORT-REC FROM COND-CLASSW.
- 064600 MOVE "F" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
- 064700 MOVE 28OT TO 40OT.
- 064800 MOVE 29OT TO 41OT.
- 064900 RELEASE SORT-REC FROM COND-CLASSW.
- 065000 MOVE "P" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
- 065100 MOVE 32OT TO 40OT.
- 065200 MOVE 33OT TO 41OT.
- 065300 RELEASE SORT-REC FROM COND-CLASSW.
- 065400 MOVE "C" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
- 065500 MOVE 32OTXX TO 40OT.
- 065600 MOVE 33OTXX TO 41OT.
- 065700 RELEASE SORT-REC FROM COND-CLASSW.
- 065800 MOVE "U" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
- 065900 MOVE 32OTX TO 40OT.
- 066000 MOVE 33OTX TO 41OT.
- 066100 RELEASE SORT-REC FROM COND-CLASSW.
- 066200 MOVE ALOT-W TO ALOT-H, HD6-ALOT.
- 066300 MOVE RS-S-VST-CC TO RS-S-VST-CC-H.
- 066400 MOVE RNG-SITE-W TO RNG-SITE-P.
- 066500 MOVE STRAT-W TO STRAT-P.
- 066600 MOVE VEG-SUB-TYP-W TO VEG-SUB-TYP-P.
- 066700 MOVE COND-CLASS-W TO COND-CLASS-P.
- 066800 MOVE ZEROS TO 16OT, 17OT, 20OT, 21OT, 24OT, 25OT,
- 066900 28OT, 29OT, 32OT, 33OT, 32OTX, 33OTX, 32OTXX, 33OTXX.
- 067000 340-AC-EXIT. EXIT.
- 067100 400-HDGS1.
- 067200 ADD 1 TO PAGECT.
- 067300 MOVE PAGECT TO HDR-PG.
- 067400 MOVE SPACES TO PRINT-REC.
- 067500 WRITE PRINT-REC AFTER ADVANCING PAGE.
- 067600 MOVE HD1 TO PRINT-REC.
- 067700 WRITE PRINT-REC.
- 067800 MOVE HD3 TO PRINT-REC.
- 067900 WRITE PRINT-REC.
- 068000 MOVE HD4 TO PRINT-REC.
- 068100 WRITE PRINT-REC.
- 068200 MOVE HD5 TO PRINT-REC.
- 068300 WRITE PRINT-REC.
- 068400 MOVE HD6 TO PRINT-REC.
- 068500 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 068600 MOVE 8 TO LINECT.
- 068700 400-HDGS1-EXIT. EXIT.
- 068800 400-HDGS1A.
- 068900 MOVE HD7 TO PRINT-REC.
- 069000 WRITE PRINT-REC.
- 069100 MOVE HD8 TO PRINT-REC.
- 069200 WRITE PRINT-REC.
- 069300 MOVE HD9 TO PRINT-REC.
- 069400 WRITE PRINT-REC.
- 069500 MOVE SPACES TO PRINT-REC.
- 069600 WRITE PRINT-REC.
- 069700 ADD 4 TO LINECT.
- 069800 400-HDGS1A-EXIT. EXIT.
- 069900 500-CP.
- 070000 MOVE PW1X TO PERCENT.
- 070100 500-CP-EXIT. EXIT.
- 070200 510-CLOSE-INPUT.
- 070300 IF LINECT > 50 PERFORM 400-HDGS1 THRU 400-HDGS1-EXIT
- 070400 PERFORM 400-HDGS1A THRU 400-HDGS1A-EXIT.
- 070500 ADD 10OT, 11OT GIVING 12OT.
- 070600 MOVE 10OT TO 10PT.
- 070700 MOVE 11OT TO 11PT.
- 070800 MOVE 12OT TO 12PT.
- 070900 MOVE DATA1 TO PRINT-REC WRITE PRINT-REC.
- 071000 ADD 1 TO LINECT.
- 071100 ADD 10OT TO 13OT ADD 11OT TO 14OT.
- 071200 ADD 13OT, 14OT GIVING 15OT.
- 071300 MOVE 13OT TO 13PT.
- 071400 MOVE 14OT TO 14PT.
- 071500 MOVE 15OT TO 15PT.
- 071600 IF DET-CNT = 1
- 071700 GO TO 520-PASS-FINAL-STRAT-TOT.
- 071800 MOVE DATA2 TO PRINT-REC
- 071900 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 072000 MOVE SPACES TO PRINT-REC.
- 072100 WRITE PRINT-REC.
- 072200 ADD 3 TO LINECT.
- 072300 520-PASS-FINAL-STRAT-TOT.
- 072400 MOVE ZERO TO DET-CNT.
- 072500 ADD 13OT TO 16OT ADD 14OT TO 17OT.
- 072600 ADD 16OT, 17OT GIVING 18OT.
- 072700 MOVE 16OT TO 16PT.
- 072800 MOVE 17OT TO 17PT.
- 072900 MOVE 18OT TO 18PT.
- 073000 IF LINECT > 38 PERFORM 400-HDGS1 THRU 400-HDGS1-EXIT.
- 073100 MOVE DATA3 TO PRINT-REC.
- 073200 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 073300 ADD 2 TO LINECT.
- 073400 IF COND-CLASS-P = "E"
- 073500 ADD 10OT TO 20OT ADD 11OT TO 21OT
- 073600 ELSE IF COND-CLASS-P = "G"
- 073700 ADD 10OT TO 24OT ADD 11OT TO 25OT
- 073800 ELSE IF COND-CLASS-P = "F"
- 073900 ADD 10OT TO 28OT ADD 11OT TO 29OT
- 074000 ELSE IF COND-CLASS-P = "P"
- 074100 ADD 10OT TO 32OT ADD 11OT TO 33OT
- 074200 ELSE IF COND-CLASS-P = "C"
- 074300 ADD 10OT TO 32OTXX ADD 11OT TO 33OTXX
- 074400 ELSE IF COND-CLASS-P = "U" ADD 10OT TO 32OTX
- 074500 ADD 11OT TO 33OTX
- 074600 ELSE ADD 10OT TO 32OTX ADD 11OT TO 33OTX.
- 074700 ADD 20OT, 21OT GIVING 22OT.
- 074800 ADD 24OT, 25OT GIVING 26OT.
- 074900 ADD 28OT, 29OT GIVING 30OT.
- 075000 ADD 32OT, 33OT GIVING 34OT.
- 075100 ADD 32OTX, 33OTX GIVING 34OTX.
- 075200 ADD 32OTXX, 33OTXX GIVING 34OTXX.
- 075300 MOVE HD10 TO PRINT-REC.
- 075400 WRITE PRINT-REC AFTER 2 LINES.
- 075500 MOVE "EXCELLENT" TO 19-31PT.
- 075600 MOVE 20OT TO 20-32PT.
- 075700 MOVE 21OT TO 21-33PT.
- 075800 MOVE 22OT TO 22-34PT.
- 075900 DIVIDE 18OT INTO 22OT GIVING PW1 ROUNDED.
- 076000 PERFORM 500-CP THRU 500-CP-EXIT.
- 076100 MOVE DATA4 TO PRINT-REC.
- 076200 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 076300 MOVE "GOOD " TO 19-31PT.
- 076400 MOVE 24OT TO 20-32PT.
- 076500 MOVE 25OT TO 21-33PT.
- 076600 MOVE 26OT TO 22-34PT.
- 076700 DIVIDE 18OT INTO 26OT GIVING PW1 ROUNDED.
- 076800 PERFORM 500-CP THRU 500-CP-EXIT.
- 076900 MOVE DATA4 TO PRINT-REC.
- 077000 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 077100 MOVE "FAIR " TO 19-31PT.
- 077200 MOVE 28OT TO 20-32PT.
- 077300 MOVE 29OT TO 21-33PT.
- 077400 MOVE 30OT TO 22-34PT.
- 077500 DIVIDE 18OT INTO 30OT GIVING PW1 ROUNDED.
- 077600 PERFORM 500-CP THRU 500-CP-EXIT.
- 077700 MOVE DATA4 TO PRINT-REC.
- 077800 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 077900 MOVE "POOR " TO 19-31PT.
- 078000 MOVE 32OT TO 20-32PT.
- 078100 MOVE 33OT TO 21-33PT.
- 078200 MOVE 34OT TO 22-34PT.
- 078300 DIVIDE 18OT INTO 34OT GIVING PW1 ROUNDED.
- 078400 PERFORM 500-CP THRU 500-CP-EXIT.
- 078500 MOVE DATA4 TO PRINT-REC.
- 078600 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 078700 MOVE "CROPLAND " TO 19-31PT.
- 078800 MOVE 32OTXX TO 20-32PT.
- 078900 MOVE 33OTXX TO 21-33PT.
- 079000 MOVE 34OTXX TO 22-34PT.
- 079100 DIVIDE 18OT INTO 34OTXX GIVING PW1 ROUNDED.
- 079200 PERFORM 500-CP THRU 500-CP-EXIT.
- 079300 MOVE DATA4 TO PRINT-REC.
- 079400 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 079500 MOVE "UNSUITABLE" TO 19-31PT.
- 079600 MOVE 32OTX TO 20-32PT.
- 079700 MOVE 33OTX TO 21-33PT.
- 079800 MOVE 34OTX TO 22-34PT.
- 079900 DIVIDE 18OT INTO 34OTX GIVING PW1 ROUNDED.
- 080000 PERFORM 500-CP THRU 500-CP-EXIT.
- 080100 MOVE DATA4 TO PRINT-REC.
- 080200 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 080300 MOVE SOIL-SER-P TO SOIL-SER-SSW, SOIL-SER-KEY-SSW.
- 080400 MOVE 10OT TO 44OT.
- 080500 MOVE 11OT TO 45OT.
- 080600 RELEASE SORT-REC FROM SOIL-SERIESW.
- 080700 MOVE STRAT-P TO STRAT-SW, STRAT-KEY-SW.
- 080800 MOVE 13OT TO 36OT.
- 080900 MOVE 14OT TO 37OT.
- 081000 RELEASE SORT-REC FROM STRATUMW.
- 081100 MOVE "E" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
- 081200 MOVE 20OT TO 40OT.
- 081300 MOVE 21OT TO 41OT.
- 081400 RELEASE SORT-REC FROM COND-CLASSW.
- 081500 MOVE "G" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
- 081600 MOVE 24OT TO 40OT.
- 081700 MOVE 25OT TO 41OT.
- 081800 RELEASE SORT-REC FROM COND-CLASSW.
- 081900 MOVE "F" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
- 082000 MOVE 28OT TO 40OT.
- 082100 MOVE 29OT TO 41OT.
- 082200 RELEASE SORT-REC FROM COND-CLASSW.
- 082300 MOVE "P" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
- 082400 MOVE 32OT TO 40OT.
- 082500 MOVE 33OT TO 41OT.
- 082600 RELEASE SORT-REC FROM COND-CLASSW.
- 082700 MOVE "C" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
- 082800 MOVE 32OTXX TO 40OT.
- 082900 MOVE 33OTXX TO 41OT.
- 083000 RELEASE SORT-REC FROM COND-CLASSW.
- 083100 MOVE "U" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
- 083200 MOVE 32OTX TO 40OT.
- 083300 MOVE 33OTX TO 41OT.
- 083400 RELEASE SORT-REC FROM COND-CLASSW.
- 083500 MOVE ZEROS TO LINECT.
- 083600 CLOSE ACRE-STRATUM-FILE.
- 083700 590-DB-HDR.
- 083800 MOVE ADSTDSRA-CD-H TO DE-CD-8822-DEC.
- 083900 MOVE 0003 TO DE-NO-8801-DEC.
- 084000 FIND ANY CODE-DEC.
- 084100 MOVE DB-STATUS TO DB-STAT.
- 084200 IF NOT OK
- 084300 MOVE ADST-CD-H TO HD4-ST
- 084400 MOVE DIST-CD-H TO HD4-DS
- 084500 MOVE RA-CD-H TO HD5-RA HD1RX-RA
- 084600 GO TO 590-EXIT.
- 084700 GET CODE-DEC.
- 084800 MOVE DB-STATUS TO DB-STAT.
- 084900 IF NOT OK
- 085000 MOVE ADST-CD-H TO HD4-ST
- 085100 MOVE DIST-CD-H TO HD4-DS
- 085200 MOVE RA-CD-H TO HD5-RA HD1RX-RA
- 085300 GO TO 590-EXIT.
- 085400 MOVE DE-CD-NAM-8823-DEC TO ST-NAM-HLD.
- 085500 MOVE ST-NAME TO HD4-ST.
- 085600 FIND NEXT CODE-EXPL-DECE
- 085700 WITHIN DEC-DECE.
- 085800 MOVE DB-STATUS TO DB-STAT.
- 085900 IF NOT OK
- 086000 MOVE DIST-CD-H TO HD4-DS
- 086100 MOVE RA-CD-H TO HD5-RA HD1RX-RA
- 086200 GO TO 590-EXIT.
- 086300 GET CODE-EXPL-DECE.
- 086400 MOVE DB-STATUS TO DB-STAT.
- 086500 IF NOT OK
- 086600 MOVE DIST-CD-H TO HD4-DS
- 086700 GO TO 590-EXIT.
- 086800 MOVE DE-CD-EXPLN-8827-DECE TO DRP-NAM-HLD.
- 086900 MOVE DS-NAME TO HD4-DS.
- 087000 MOVE RA-NAME TO HD5-RA HD1RX-RA.
- 087100 590-EXIT.
- 087200 EXIT.
- 087300 600-OUTPUT SECTION.
- 087400 610-OUTPUT.
- 087500 610-RETURN1.
- 087600 RETURN SORT-FILE AT END GO TO 900-CLOSE.
- 087700* DISPLAY "SR= " SORT-REC.
- 087800 MOVE SORT-REC TO HOLD-SORT-REC.
- 087900 IF KEYR1 NOT = KEYR1H
- 088000 PERFORM 700-HD-CKR THRU 700-EXIT
- 088100 GO TO 610-RETURN1.
- 088200 PERFORM 620-SUM-PROCESS THRU 620-SP-EXIT.
- 088300 GO TO 610-RETURN1.
- 088400 620-SUM-PROCESS.
- 088500 IF 35-43R = 35-43RH
- 088600 ADD 36R TO 36RH, 36RHT ADD 37R TO 37RH, 37RHT
- 088700 GO TO 620-SP-EXIT.
- 088800 IF LINECT > 53 PERFORM 800-OFLO-HD2 THRU 800-EXIT.
- 088900 ADD 36RH, 37RH GIVING 38RH.
- 089000 IF FLAGG1 = 1
- 089100 MOVE 36RH TO 36-44RX
- 089200 MOVE 37RH TO 37-45RX
- 089300 MOVE 38RH TO 38-46RX
- 089400 DIVIDE 38RHT INTO 38RH GIVING PW1 ROUNDED
- 089500 MOVE PW1X TO PERCENTS
- 089600 MOVE HD4RX TO PRINT-REC
- 089700 WRITE PRINT-REC
- 089800 ELSE
- 089900 MOVE 36RH TO 36-44R
- 090000 MOVE 37RH TO 37-45R
- 090100 MOVE 38RH TO 38-46R
- 090200 MOVE HD4R TO PRINT-REC
- 090300 WRITE PRINT-REC.
- 090400 ADD 1 TO LINECT.
- 090500 MOVE 35-43R TO 35-43RH.
- 090600 IF KEYR1 = 1
- 090700 MOVE 35-43R TO 35R2
- 090800 MOVE 35R TO HD4-NAME.
- 090900 IF (KEYR1 = 2) AND (39R = "E")
- 091000 MOVE "EXCELLENT " TO HD4-NAMEX
- 091100 ELSE IF (KEYR1 = 2) AND (39R = "G")
- 091200 MOVE "GOOD " TO HD4-NAMEX
- 091300 ELSE IF (KEYR1 = 2) AND (39R = "F")
- 091400 MOVE "FAIR " TO HD4-NAMEX
- 091500 ELSE IF (KEYR1 = 2) AND (39R = "P")
- 091600 MOVE "POOR " TO HD4-NAMEX
- 091700 ELSE IF (KEYR1 = 2) AND (39R = "C")
- 091800 MOVE "CROPLAND " TO HD4-NAMEX
- 091900 ELSE IF (KEYR1 = 2) AND (39R = "U")
- 092000 MOVE "UNSUITABLE" TO HD4-NAMEX.
- 092100 IF KEYR1 = 3
- 092200 MOVE 35-43R TO 43R2
- 092300 MOVE 43R TO HD4-NAME.
- 092400 MOVE 36R TO 36RH.
- 092500 MOVE 37R TO 37RH.
- 092600 ADD 36R TO 36RHT.
- 092700 ADD 37R TO 37RHT.
- 092800 620-SP-EXIT. EXIT.
- 092900 700-HD-CKR.
- 093000 IF KEYR1 = 1
- 093100 MOVE " RESOURCE ACREAGE INFORMATION" TO HD5-NAME
- 093200 MOVE KEYR1 TO KEYR1H
- 093300 MOVE 35-43R TO 35-43RH, 35R2
- 093400 MOVE 35R TO HD4-NAME
- 093500 PERFORM 620-SUM-PROCESS THRU 620-SP-EXIT
- 093600 PERFORM 810-OFLO-HD3 THRU 810-EXIT
- 093700 GO TO 700-EXIT.
- 093800 IF KEYR1 = 2
- 093900 MOVE KEYR1 TO KEYR1H
- 094000 PERFORM 820-CK-OFLO THRU 820-EXIT
- 094100 ADD 36RHT, 37RHT GIVING 38RHT
- 094200 MOVE 36RHT TO 36-44RT
- 094300 MOVE 37RHT TO 37-45RT
- 094400 MOVE 38RHT TO 38-46RT
- 094500 MOVE ZEROS TO 36RHT, 37RHT
- 094600 PERFORM 620-SUM-PROCESS THRU 620-SP-EXIT
- 094700 MOVE HD5R TO PRINT-REC
- 094800 WRITE PRINT-REC AFTER ADVANCING 3 LINES
- 094900 MOVE 1 TO FLAGG1
- 095000 MOVE "RANGE CONDITION SUMMARY" TO HD1-NAME, HD1RX-NAME
- 095100 MOVE "CONDITION CLASS" TO HD3-NAME
- 095200 PERFORM 810-OFLO-HD3 THRU 810-EXIT
- 095300 GO TO 700-EXIT.
- 095400 IF KEYR1 = 3
- 095500 MOVE KEYR1 TO KEYR1H
- 095600 PERFORM 820-CK-OFLO THRU 820-EXIT
- 095700 ADD 36RHT, 37RHT GIVING 38RHT
- 095800 MOVE 36RHT TO 36-44RT
- 095900 MOVE 37RHT TO 37-45RT
- 096000 MOVE 38RHT TO 38-46RT
- 096100 MOVE ZEROS TO 36RHT, 37RHT
- 096200 PERFORM 620-SUM-PROCESS THRU 620-SP-EXIT
- 096300 MOVE HD5R TO PRINT-REC
- 096400 WRITE PRINT-REC AFTER ADVANCING 3 LINES
- 096500 MOVE 0 TO FLAGG1
- 096600 MOVE " SOIL SERIES SUMMARY " TO HD1-NAME, HD1RX-NAME
- 096700 MOVE " SOIL SERIES " TO HD3-NAME
- 096800 PERFORM 810-OFLO-HD3 THRU 810-EXIT
- 096900 GO TO 700-EXIT.
- 097000 700-EXIT. EXIT.
- 097100 800-OFLO-HD2.
- 097200 ADD 1 TO PAGECT.
- 097300 MOVE PAGECT TO PG-NOX.
- 097400 MOVE SPACES TO PRINT-REC.
- 097500 WRITE PRINT-REC AFTER ADVANCING PAGE.
- 097600 MOVE HD1RX TO PRINT-REC.
- 097700 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 097800 MOVE HD2R TO PRINT-REC.
- 097900 WRITE PRINT-REC AFTER ADVANCING 3 LINES.
- 098000 MOVE HD3R TO PRINT-REC.
- 098100 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 098200 MOVE SPACES TO PRINT-REC WRITE PRINT-REC.
- 098300 MOVE 9 TO LINECT.
- 098400 800-EXIT. EXIT.
- 098500 810-OFLO-HD3.
- 098600 ADD 1 TO PAGECT.
- 098700 MOVE PAGECT TO HDR-PG.
- 098800 MOVE SPACES TO PRINT-REC.
- 098900 WRITE PRINT-REC AFTER ADVANCING PAGE.
- 099000 MOVE HD1 TO PRINT-REC.
- 099100 WRITE PRINT-REC.
- 099200 MOVE HD3 TO PRINT-REC.
- 099300 WRITE PRINT-REC.
- 099400 MOVE HD4 TO PRINT-REC.
- 099500 WRITE PRINT-REC.
- 099600 MOVE HD5 TO PRINT-REC.
- 099700 WRITE PRINT-REC.
- 099800 MOVE HD1R TO PRINT-REC.
- 099900 WRITE PRINT-REC AFTER ADVANCING 3 LINES.
- 100000 MOVE HD2R TO PRINT-REC.
- 100100 WRITE PRINT-REC AFTER ADVANCING 3 LINES.
- 100200 MOVE HD3R TO PRINT-REC.
- 100300 WRITE PRINT-REC AFTER ADVANCING 2 LINES.
- 100400 MOVE SPACES TO PRINT-REC.
- 100500 WRITE PRINT-REC.
- 100600 MOVE 15 TO LINECT.
- 100700 810-EXIT. EXIT.
- 100800 820-CK-OFLO.
- 100900 IF LINECT > 53 PERFORM 800-OFLO-HD2 THRU 800-EXIT.
- 101000 820-EXIT. EXIT.
- 101100 900-CLOSE.
- 101200 IF LINECT > 53 PERFORM 800-OFLO-HD2 THRU 800-EXIT.
- 101300 ADD 36RH, 37RH GIVING 38RH.
- 101400 MOVE 36RH TO 36-44R.
- 101500 MOVE 37RH TO 37-45R.
- 101600 MOVE 38RH TO 38-46R.
- 101700 MOVE HD4R TO PRINT-REC.
- 101800 WRITE PRINT-REC.
- 101900 IF LINECT > 53 PERFORM 800-OFLO-HD2 THRU 800-EXIT.
- 102000 ADD 36RHT, 37RHT GIVING 38RHT.
- 102100 MOVE 36RHT TO 36-44RT.
- 102200 MOVE 37RHT TO 37-45RT.
- 102300 MOVE 38RHT TO 38-46RT.
- 102400 MOVE HD5R TO PRINT-REC.
- 102500 WRITE PRINT-REC AFTER ADVANCING 3 LINES.
- 102600 DISPLAY "PAGES PRINTED " PAGECT.
- 102700 CLOSE PRINT-FILE.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES520P.
- 000300* ALLOTMENT LEVEL STRATIFICATION SUMMARY (P2 LIST)
- 000400*
- 000500 AUTHOR. M.QUANDT.
- 000700 ENVIRONMENT DIVISION.
- 000800 CONFIGURATION SECTION.
- 000900 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001000 OBJECT-COMPUTER. LEVEL-66-ASCII, SEQUENCE IS EBCDIC.
- 001100 INPUT-OUTPUT SECTION.
- 001200 FILE-CONTROL.
- 001300 SELECT INPUT-FILE ASSIGN TO I1
- 001400 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001500 SELECT PRINT-OUT ASSIGN TO P1
- 001600 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001700 SELECT SWA-FILE ASSIGN TO D1
- 001800 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001900 DATA DIVISION.
- 002000 SUB-SCHEMA SECTION.
- 002100 DB CODVAL2 WITHIN BLMDIC.
- 002200 FILE SECTION.
- 002300 FD INPUT-FILE
- 002400 CODE-SET IS GBCD
- 002500 LABEL RECORDS ARE STANDARD.
- 002600 01 IN-RECORD.
- 002700 05 IN-REC-TYP PIC X(2).
- 002800 05 IN-FMT-NUM PIC X.
- 002900 05 IN-FORMAT-CD PIC X.
- 003000 05 IN-BLM-ADM-U PIC X(8).
- 003100 05 IN-CLMTC-ADJ-FCTR PIC 99V999.
- 003200 05 IN-DATA-DATE PIC X(6).
- 003300 05 IN-ACTION-CD PIC X.
- 003400 05 IN-LIN-NUM PIC X(4).
- 003500 05 IN-SWA PIC X(4).
- 003600 05 IN-TRN-NUM PIC XX.
- 003700 05 IN-SWA-PCT PIC 999.
- 003800 05 IN-RNG-SITE-ID PIC X(11).
- 003900 05 IN-STRATUM-NUM PIC X(4).
- 004000 05 IN-ALLOT-NUM PIC X(4).
- 004100 05 IN-PASTURE-NUM PIC XX.
- 004200 05 IN-VEG-SUB-TYP PIC X(4).
- 004300 05 IN-RNG-ECOL-COND-CLS PIC X.
- 004400 05 IN-PCT-SLP PIC XXX.
- 004500 05 IN-ASPT PIC XX.
- 004600 05 IN-L-FORM PIC XXX.
- 004700 05 IN-SOIL-PHAS PIC X(5).
- 004800 05 FILLER PIC XX.
- 004900 FD PRINT-OUT
- 005000 CODE-SET IS GBCD
- 005100 LABEL RECORDS ARE STANDARD.
- 005200 01 PRINT-LINE PIC X(132).
- 005300 FD SWA-FILE
- 005400 CODE-SET IS GBCD
- 005500 LABEL RECORDS ARE STANDARD
- 005600 DATA RECORD IS SWA-REC.
- 005700 01 SWA-REC.
- 005800 05 OT-ST-DIST-RA-PLU PIC X(8).
- 005900 05 OT-SWA PIC X(4).
- 006000 05 OT-TRANSECT PIC 99.
- 006100 05 OT-RANGE-SITE PIC X(11).
- 006200 05 OT-STRATUM PIC 9(4).
- 006300 05 OT-SWA-PERCENT PIC 9(3).
- 006400 05 OT-ALLOTMENT PIC 9(4).
- 006500 05 OT-PASTURE PIC 99.
- 006600 05 OT-COMPARISON-AREA PIC X.
- 006700 05 OT-CLIMATIC-ADJ-FCTR PIC 99V999.
- 006800 05 OT-COND-CLS PIC X.
- 006900 05 SPACE-FILL PIC X(3).
- 007000 WORKING-STORAGE SECTION.
- 007100 77 TRAN-INDX PIC 999 VALUE ZERO.
- 007200 77 TRANS-CNT PIC 999 VALUE ZERO.
- 007300 77 PERCENT-ACCUL PIC 999 VALUE ZEROS.
- 007400 77 NEW-SKEY PIC X(8).
- 007500 77 OLD-SKEY PIC X(8).
- 007600 77 PG-CNT PIC 9(5) VALUE ZEROS.
- 007700 77 WORK-SPACES PIC X(132) VALUE SPACES.
- 007800 77 WORK-PRINT PIC X(132).
- 007900 77 LINE-COUNT PIC 99 VALUE ZEROS.
- 008000 77 WORK-PASTURE PIC XX.
- 008100 77 READ-COUNT PIC 9(7) VALUE ZERO.
- 008200 77 READ-COUNT-VB PIC 9(7) VALUE ZERO.
- 008300 77 WRITE-COUNT PIC 9(7) VALUE ZERO.
- 008400 77 NEW-ALLOT PIC X(4).
- 008500 77 OLD-ALLOT PIC X(4).
- 008600 77 NEW-PASTURE PIC XX.
- 008700 77 OLD-PASTURE PIC XX.
- 008800 77 NEW-SWA PIC X(4).
- 008900 77 OLD-SWA PIC X(4).
- 009000 77 NEW-STRA PIC X(4).
- 009100 77 OLD-STRA PIC X(4).
- 009200 01 SAVE-TRANSECT-TABLE.
- 009300 05 SAVE-TRANSECT PIC 99 OCCURS 100 TIMES.
- 009400 01 ZERO-CONDITION PIC 9 VALUE IS ZERO.
- 009500 88 ZERO-TRANSECT VALUE IS 1.
- 009600 01 SAVED-DATA.
- 009700 05 FILLER PIC X(13) VALUE SPACES.
- 009800 05 SAVE-ALLOT PIC X(4).
- 009900 05 FILLER PIC X(17) VALUE SPACES.
- 010000 05 SAVE-PASTURE PIC XX.
- 010100 05 FILLER PIC X(16) VALUE SPACES.
- 010200 05 SAVE-SWA PIC X(4).
- 010300 01 HOLD-AREA.
- 010400 03 ADST-DIST-RA-PLU-CDS-H.
- 010500 05 ADST-CD-H PIC XX.
- 010600 05 DIST-CD-H PIC XX.
- 010700 05 RA-CD-H PIC XX.
- 010800 05 PLU-CD-H PIC XX.
- 010900 03 DE-CD-EXPLN-8827-DECE-H.
- 011000 05 DIST-NAM-H PIC X(12).
- 011100 05 RA-NAM-H PIC X(13).
- 011200 05 PLU-NAM-H PIC X(15).
- 011300 03 DE-CD-NAM-8823-DEC-H.
- 011400 05 ST-NAM-H PIC X(10).
- 011500 05 FILLER PIC X(14).
- 011600 01 WS-IN-RECORD.
- 011700 05 WS-REC-TYP PIC X(2).
- 011800 05 WS-FMT-NUM PIC X.
- 011900 05 WS-FORMAT-CD PIC X.
- 012000 05 WS-BLM-ADM-U PIC X(8).
- 012100 05 WS-CLMTC-ADJ-FCTR PIC 99V999.
- 012200 05 WS-DATA-DATE PIC X(6).
- 012300 05 WS-ACTION-CD PIC X.
- 012400 05 WS-LIN-NUM PIC X(4).
- 012500 05 WS-SWA PIC X(4).
- 012600 05 WS-TRN-NUM PIC XX.
- 012700 05 WS-SWA-PCT PIC 999.
- 012800 05 WS-RNG-SITE-ID PIC X(11).
- 012900 05 WS-STRATUM-NUM PIC X(4).
- 013000 05 WS-ALLOT-NUM PIC X(4).
- 013100 05 WS-PASTURE-NUM PIC XX.
- 013200 05 WS-VEG-SUB-TYP PIC X(4).
- 013300 05 WS-RNG-ECOL-COND-CLS PIC X.
- 013400 05 WS-PCT-SLP PIC XXX.
- 013500 05 WS-ASPT PIC XX.
- 013600 05 WS-L-FORM PIC XXX.
- 013700 05 WS-SOIL-PHAS PIC X(5).
- 013800 05 FILLER PIC XX.
- 013900 01 PAG-HDR-1.
- 014000 03 FILLER PIC X(13) VALUE "REPORT DATE: ".
- 014100 03 HEADER-DATE.
- 014200 05 MO-HDR PIC 99.
- 014300 05 FILLER PIC X VALUE "/".
- 014400 05 DA-HDR PIC 99.
- 014500 05 FILLER PIC X VALUE "/".
- 014600 05 YR-HDR PIC 99.
- 014700 03 FILLER PIC X(28) VALUE SPACES.
- 014800 03 FILLER PIC X(23) VALUE "U.S.D.I. BUREAU OF LAND".
- 014900 03 FILLER PIC X(11) VALUE " MANAGEMENT".
- 015000 03 FILLER PIC X(22) VALUE SPACES.
- 015100 03 FILLER PIC X(15) VALUE "PCN: P020 ".
- 015200 03 FILLER PIC X(6) VALUE " PAGE ".
- 015300 03 PAGE-NO PIC ZZ,ZZ9.
- 015400 01 PAG-HDR-3.
- 015500 03 FILLER PIC X(20) VALUE " STATE ".
- 015600 03 STATE-NAME PIC X(10).
- 015700 03 FILLER PIC X(24) VALUE SPACES.
- 015800 03 FILLER PIC X(21) VALUE "ECOLOGICAL SITE INVEN".
- 015900 03 FILLER PIC X(04) VALUE "TORY".
- 016000 03 FILLER PIC X(53) VALUE SPACES.
- 016100 01 PAG-HDR-4.
- 016200 03 FILLER PIC X(20) VALUE " DISTRICT ".
- 016300 03 DIST-NAME PIC X(12).
- 016400 03 FILLER PIC X(100) VALUE SPACES.
- 016500 01 PAG-HDR-5.
- 016600 03 FILLER PIC X(20) VALUE " RESOURCE AREA ".
- 016700 03 RA-NAME PIC X(13).
- 016800 03 FILLER PIC X(13) VALUE SPACES.
- 016900 03 FILLER PIC X(19) VALUE "ALLOTMENT LEVEL STR".
- 017000 03 FILLER PIC X(19) VALUE "ATIFICATION SUMMARY".
- 017100 03 FILLER PIC X(46) VALUE SPACES.
- 017200 01 PAG-HDR-6.
- 017300 03 FILLER PIC X(20) VALUE " PLANNING UNIT ".
- 017400 03 PU-NAME PIC X(15).
- 017500 03 FILLER PIC X(97) VALUE SPACES.
- 017600 01 COL-HDR-1.
- 017700 03 FILLER PIC X(11) VALUE SPACES.
- 017800 03 FILLER PIC X(9) VALUE "ALLOTMENT".
- 017900 03 FILLER PIC X(12) VALUE SPACES.
- 018000 03 FILLER PIC X(7) VALUE "PASTURE".
- 018100 03 FILLER PIC X(14) VALUE SPACES.
- 018200 03 FILLER PIC X(3) VALUE "SWA".
- 018300 03 FILLER PIC X(16) VALUE SPACES.
- 018400 03 FILLER PIC X(7) VALUE "STRATUM".
- 018500 03 FILLER PIC X(12) VALUE SPACES.
- 018600 03 FILLER PIC X(8) VALUE "% OF SWA".
- 018700 03 FILLER PIC X(11) VALUE SPACES.
- 018800 03 FILLER PIC X(10) VALUE "RANGE SITE".
- 018900 03 FILLER PIC X(12) VALUE SPACES.
- 019000 01 DATA-LINE-1.
- 019100 03 FILLER PIC X(13) VALUE SPACES.
- 019200 03 ALLOT-P PIC X(4).
- 019300 03 FILLER PIC X(17) VALUE SPACES.
- 019400 03 PASTURE-P PIC XX.
- 019500 03 FILLER PIC X(16) VALUE SPACES.
- 019600 03 SWA-P PIC X(4).
- 019700 03 FILLER PIC X(17) VALUE SPACES.
- 019800 03 STRATUM-P PIC 9(4).
- 019900 03 FILLER PIC X(16) VALUE SPACES.
- 020000 03 PCT-SWA-P PIC ZZ9.
- 020100 03 FILLER PIC X(14) VALUE SPACES.
- 020200 03 RNG-SITE-P PIC X(11).
- 020300 03 FILLER PIC X(11) VALUE SPACES.
- 020400 01 DATA-LINE-2 REDEFINES DATA-LINE-1 PIC X(132).
- 020500 01 DATE-TODAY.
- 020600 05 THIS-YEAR PIC 99.
- 020700 05 THIS-MONTH PIC 99.
- 020800 05 THIS-DAY PIC 99.
- 020900 01 EOF-CONDITION PIC 9.
- 021000 88 FILE-END VALUE IS 1.
- 021100 PROCEDURE DIVISION.
- 021200 10-HOUSEKEEPING.
- 021300 PERFORM 200-HOUSEKEEP THRU 205-EXIT.
- 021400 20-MAINLINE.
- 021500 PERFORM 210-READ-INPUT.
- 021600 IF FILE-END
- 021700 PERFORM 900-WRAPUP
- 021800 STOP RUN.
- 021900 IF IN-REC-TYP NOT EQUAL "VB"
- 022000 GO TO 20-MAINLINE.
- 022100 ADD 1 TO READ-COUNT-VB.
- 022200 IF IN-PASTURE-NUM EQUAL "00"
- 022300 MOVE SPACES TO WORK-PASTURE
- 022400 ELSE MOVE IN-PASTURE-NUM TO WORK-PASTURE.
- 022500 PERFORM 240-SKEY-CHANGE.
- 022600 PERFORM 220-ALLOT-CHANGE THRU 226-STRA-CHANGE.
- 022700 IF NEW-SKEY NOT EQUAL OLD-SKEY
- 022800 OR NEW-ALLOT NOT EQUAL OLD-ALLOT
- 022900 PERFORM 700-SAVE-TO-LINE
- 023000 PERFORM 500-MOVE-ALLOT THRU 520-MOVE-SWA
- 023100 GO TO 30-BYPASS.
- 023200 IF NEW-PASTURE NOT EQUAL OLD-PASTURE
- 023300 PERFORM 700-SAVE-TO-LINE
- 023400 PERFORM 510-MOVE-PASTURE THRU 520-MOVE-SWA
- 023500 GO TO 30-BYPASS.
- 023600 IF NEW-SWA NOT EQUAL OLD-SWA
- 023700 PERFORM 700-SAVE-TO-LINE
- 023800 PERFORM 520-MOVE-SWA
- 023900 GO TO 30-BYPASS.
- 024000 IF NEW-STRA NOT EQUAL OLD-STRA
- 024100 PERFORM 700-SAVE-TO-LINE
- 024200 GO TO 30-BYPASS.
- 024300 GO TO 40-CALCULATE.
- 024400 30-BYPASS.
- 024500 IF LINE-COUNT GREATER 54
- 024600 PERFORM 710-1ST-LINE-MOVE.
- 024700 PERFORM 310-MOVE-TO-PRINT THRU 330-MOVE-WRITE-FILE.
- 024800 IF NEW-SKEY NOT EQUAL OLD-SKEY
- 024900 PERFORM 250-SKEY-TO-HDR THRU 260-TOP-PAGE.
- 025000 PERFORM 230-INITIAL-ACCUL.
- 025100 PERFORM 610-EXCHANGE.
- 025200 40-CALCULATE.
- 025300 PERFORM 300-PERCENT-ADD.
- 025400 GO TO 20-MAINLINE.
- 025500 200-HOUSEKEEP.
- 025600 OPEN INPUT INPUT-FILE.
- 025700 OPEN OUTPUT PRINT-OUT SWA-FILE.
- 025800 READY DIC-DE.
- 025900 MOVE SPACES TO PRINT-LINE.
- 026000 MOVE ZERO TO EOF-CONDITION.
- 026100 INITIALIZE SWA-REC.
- 026200 ACCEPT DATE-TODAY FROM DATE.
- 026300 MOVE THIS-DAY TO DA-HDR.
- 026400 MOVE THIS-MONTH TO MO-HDR.
- 026500 MOVE THIS-YEAR TO YR-HDR.
- 026600 201-READ-LOOP.
- 026700 PERFORM 210-READ-INPUT.
- 026800 IF FILE-END
- 026900 DISPLAY "NO RECORD IN INPUT FILE"
- 027000 PERFORM 900-WRAPUP
- 027100 STOP RUN.
- 027200 IF IN-REC-TYP NOT EQUAL "VB"
- 027300 GO TO 201-READ-LOOP.
- 027400 ADD 1 TO READ-COUNT-VB.
- 027500 IF IN-PASTURE-NUM EQUAL "00"
- 027600 MOVE SPACES TO WORK-PASTURE
- 027700 ELSE MOVE IN-PASTURE-NUM TO WORK-PASTURE.
- 027800 PERFORM 610-EXCHANGE.
- 027900 PERFORM 250-SKEY-TO-HDR.
- 028000 PERFORM 260-TOP-PAGE.
- 028100 MOVE SPACES TO SAVED-DATA.
- 028200 PERFORM 500-MOVE-ALLOT THRU 520-MOVE-SWA.
- 028300 MOVE IN-ALLOT-NUM TO NEW-ALLOT.
- 028400 MOVE IN-PASTURE-NUM TO NEW-PASTURE.
- 028500 MOVE IN-SWA TO NEW-SWA.
- 028600 MOVE IN-STRATUM-NUM TO NEW-STRA.
- 028700 MOVE IN-BLM-ADM-U TO NEW-SKEY.
- 028800 PERFORM 300-PERCENT-ADD.
- 028900 205-EXIT.
- 029000 EXIT.
- 029100 210-READ-INPUT.
- 029200 READ INPUT-FILE
- 029300 AT END MOVE 1 TO EOF-CONDITION
- 029400 SUBTRACT 1 FROM READ-COUNT.
- 029500 ADD 1 TO READ-COUNT.
- 029600 220-ALLOT-CHANGE.
- 029700 MOVE NEW-ALLOT TO OLD-ALLOT.
- 029800 MOVE IN-ALLOT-NUM TO NEW-ALLOT.
- 029900 222-PASTURE-CHANGE.
- 030000 MOVE NEW-PASTURE TO OLD-PASTURE.
- 030100 MOVE IN-PASTURE-NUM TO NEW-PASTURE.
- 030200 224-SWA-CHANGE.
- 030300 MOVE NEW-SWA TO OLD-SWA.
- 030400 MOVE IN-SWA TO NEW-SWA.
- 030500 226-STRA-CHANGE.
- 030600 MOVE NEW-STRA TO OLD-STRA.
- 030700 MOVE IN-STRATUM-NUM TO NEW-STRA.
- 030800 230-INITIAL-ACCUL.
- 030900 MOVE ZEROS TO PERCENT-ACCUL.
- 031000 240-SKEY-CHANGE.
- 031100 MOVE NEW-SKEY TO OLD-SKEY.
- 031200 MOVE IN-BLM-ADM-U TO NEW-SKEY.
- 031300 250-SKEY-TO-HDR.
- 031400 MOVE 0003 TO DE-NO-8801-DEC.
- 031500 MOVE IN-BLM-ADM-U TO DE-CD-8822-DEC.
- 031600 FIND ANY CODE-DEC.
- 031700 IF DB-STATUS NOT = ZERO
- 031800 DISPLAY "BAD STATE CODE" CALL "ABOR".
- 031900 GET CODE-DEC.
- 032000 MOVE DE-CD-NAM-8823-DEC TO DE-CD-NAM-8823-DEC-H.
- 032100 FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
- 032200 IF DB-STATUS NOT = ZERO
- 032300 DISPLAY "ST-DIST-RA-PLU IS " IN-BLM-ADM-U
- 032400 DISPLAY "BAD DIST, RA, PLU CODES" CALL "ABOR".
- 032500 GET CODE-EXPL-DECE.
- 032600 MOVE DE-CD-EXPLN-8827-DECE TO DE-CD-EXPLN-8827-DECE-H.
- 032700 MOVE ST-NAM-H TO STATE-NAME.
- 032800 MOVE RA-NAM-H TO RA-NAME.
- 032900 MOVE DIST-NAM-H TO DIST-NAME.
- 033000 MOVE PLU-NAM-H TO PU-NAME.
- 033100 260-TOP-PAGE.
- 033200 ADD 1 TO PG-CNT.
- 033300 MOVE PG-CNT TO PAGE-NO.
- 033400 IF PG-CNT = 1
- 033500 DISPLAY PAG-HDR-1
- 033600 DISPLAY PAG-HDR-3
- 033700 DISPLAY PAG-HDR-4
- 033800 DISPLAY PAG-HDR-5
- 033900 DISPLAY PAG-HDR-6
- 034000 DISPLAY SPACES
- 034100 DISPLAY COL-HDR-1
- 034200 DISPLAY SPACES.
- 034300 WRITE PRINT-LINE FROM PAG-HDR-1
- 034400 AFTER ADVANCING PAGE.
- 034500 WRITE PRINT-LINE FROM PAG-HDR-3
- 034600 AFTER ADVANCING 1 LINE.
- 034700 WRITE PRINT-LINE FROM PAG-HDR-4
- 034800 AFTER ADVANCING 1 LINE.
- 034900 WRITE PRINT-LINE FROM PAG-HDR-5
- 035000 AFTER ADVANCING 1 LINE.
- 035100 WRITE PRINT-LINE FROM PAG-HDR-6
- 035200 AFTER ADVANCING 1 LINE.
- 035300 WRITE PRINT-LINE FROM COL-HDR-1
- 035400 AFTER ADVANCING 2 LINES.
- 035500 WRITE PRINT-LINE FROM WORK-SPACES
- 035600 AFTER ADVANCING 2 LINE.
- 035700 MOVE 9 TO LINE-COUNT.
- 035800 300-PERCENT-ADD.
- 035900 IF IN-TRN-NUM EQUAL ZERO
- 036000 MOVE 1 TO ZERO-CONDITION
- 036100 ELSE ADD 1 TO TRAN-INDX
- 036200 IF TRAN-INDX GREATER 100
- 036300 DISPLAY "MORE THAN 100 TRANSECTS PER STRATUM"
- 036400 STOP RUN
- 036500 ELSE
- 036600 MOVE IN-TRN-NUM TO SAVE-TRANSECT (TRAN-INDX).
- 036700 ADD IN-SWA-PCT TO PERCENT-ACCUL.
- 036800 310-MOVE-TO-PRINT.
- 036900 MOVE PERCENT-ACCUL TO PCT-SWA-P.
- 037000 MOVE WS-STRATUM-NUM TO STRATUM-P.
- 037100 MOVE WS-RNG-SITE-ID TO RNG-SITE-P.
- 037200 MOVE DATA-LINE-1 TO WORK-PRINT.
- 037300 320-WRITE-PRINT.
- 037400 IF LINE-COUNT GREATER 54
- 037500 PERFORM 260-TOP-PAGE.
- 037600 IF PG-CNT = 1
- 037700 DISPLAY WORK-PRINT.
- 037800 WRITE PRINT-LINE FROM WORK-PRINT
- 037900 AFTER ADVANCING 1 LINE.
- 038000 ADD 1 TO LINE-COUNT.
- 038100 330-MOVE-WRITE-FILE.
- 038200 MOVE PERCENT-ACCUL TO OT-SWA-PERCENT.
- 038300 MOVE WS-BLM-ADM-U TO OT-ST-DIST-RA-PLU.
- 038400 MOVE WS-SWA TO OT-SWA.
- 038500 MOVE WS-RNG-SITE-ID TO OT-RANGE-SITE.
- 038600 MOVE WS-STRATUM-NUM TO OT-STRATUM.
- 038700 MOVE WS-RNG-ECOL-COND-CLS TO OT-COND-CLS.
- 038800 MOVE WS-ALLOT-NUM TO OT-ALLOTMENT.
- 038900 IF WS-PASTURE-NUM EQUAL SPACES
- 039000 MOVE ZEROS TO OT-PASTURE
- 039100 ELSE MOVE WS-PASTURE-NUM TO OT-PASTURE.
- 039200 MOVE WS-CLMTC-ADJ-FCTR TO OT-CLIMATIC-ADJ-FCTR.
- 039300 PERFORM 340-MOVE-TRANSECTS THRU 349-EXIT.
- 039400 MOVE ZERO TO TRAN-INDX.
- 039500 MOVE ZERO TO TRANS-CNT.
- 039600 MOVE ZERO TO ZERO-CONDITION.
- 039700 340-MOVE-TRANSECTS.
- 039800 IF ZERO-TRANSECT
- 039900 MOVE ZEROS TO OT-TRANSECT
- 040000 PERFORM 350-WRITE-SWA-REC.
- 040100 345-TRANS-LOOP.
- 040200 ADD 1 TO TRANS-CNT.
- 040300 IF TRANS-CNT GREATER TRAN-INDX
- 040400 GO TO 349-EXIT.
- 040500 MOVE SAVE-TRANSECT (TRANS-CNT) TO OT-TRANSECT
- 040600 PERFORM 350-WRITE-SWA-REC.
- 040700 GO TO 345-TRANS-LOOP.
- 040800 349-EXIT.
- 040900 EXIT.
- 041000 350-WRITE-SWA-REC.
- 041100 WRITE SWA-REC.
- 041200 ADD 1 TO WRITE-COUNT.
- 041300 500-MOVE-ALLOT.
- 041400 MOVE IN-ALLOT-NUM TO SAVE-ALLOT.
- 041500 510-MOVE-PASTURE.
- 041600 MOVE WORK-PASTURE TO SAVE-PASTURE.
- 041700 520-MOVE-SWA.
- 041800 MOVE IN-SWA TO SAVE-SWA.
- 041900 610-EXCHANGE.
- 042000 MOVE IN-RECORD TO WS-IN-RECORD.
- 042100 MOVE WORK-PASTURE TO WS-PASTURE-NUM.
- 042200 700-SAVE-TO-LINE.
- 042300 MOVE SAVED-DATA TO DATA-LINE-2.
- 042400 MOVE SPACES TO SAVED-DATA.
- 042500 710-1ST-LINE-MOVE.
- 042600 MOVE WS-ALLOT-NUM TO ALLOT-P.
- 042700 MOVE WS-PASTURE-NUM TO PASTURE-P.
- 042800 MOVE WS-SWA TO SWA-P.
- 042900 900-WRAPUP.
- 043000 MOVE SAVED-DATA TO DATA-LINE-2.
- 043100 IF LINE-COUNT GREATER 54
- 043200 MOVE WS-ALLOT-NUM TO ALLOT-P
- 043300 MOVE WS-PASTURE-NUM TO PASTURE-P
- 043400 MOVE WS-SWA TO SWA-P.
- 043500 PERFORM 310-MOVE-TO-PRINT THRU 330-MOVE-WRITE-FILE.
- 043600 FINISH DIC-DE.
- 043700 DISPLAY READ-COUNT " RECORDS READ".
- 043800 DISPLAY READ-COUNT-VB " VB RECORDS READ".
- 043900 DISPLAY WRITE-COUNT " RECORDS WRITTEN".
- 044000 CLOSE INPUT-FILE PRINT-OUT SWA-FILE.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES524Z.
- 000300* STOCKING RATE FILE BUILD.
- 000400*
- 000500 AUTHOR. RON BAKER.
- 000600 DATE-WRITTEN. NOV 81.
- 000700 DATE-COMPILED.
- 000800 ENVIRONMENT DIVISION.
- 000900 CONFIGURATION SECTION.
- 001000 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001100 OBJECT-COMPUTER. LEVEL-66-ASCII, SEQUENCE IS EBCDIC.
- 001200 INPUT-OUTPUT SECTION.
- 001300 FILE-CONTROL.
- 001400 SELECT ACRE-FILE ASSIGN TO I1
- 001500 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001600 SELECT STRATUM-FILE ASSIGN TO I2
- 001700 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001800 SELECT VM-FILE ASSIGN TO I3
- 001900 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002000 SELECT ACRE-WORK-FILE ASSIGN TO W1
- 002100 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002200 SELECT STRATUM-WORK-FILE ASSIGN TO W2
- 002300 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002400 SELECT OWNER-WORK-FILE ASSIGN TO W3
- 002500 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002600 SELECT STOCKING-FILE ASSIGN TO D1
- 002700 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002800 SELECT SORT-FILE ASSIGN TO S1 S2 S3.
- 002900 SELECT SORT-FILE-2 ASSIGN TO S1 S2 S3.
- 003000 SELECT SORT-FILE-3 ASSIGN TO S1 S2 S3.
- 003100 SELECT SORT-FILE-4 ASSIGN TO S1 S2 S3.
- 003200 DATA DIVISION.
- 003300 FILE SECTION.
- 003400 FD STOCKING-FILE
- 003500 CODE-SET IS GBCD
- 003600 LABEL RECORD IS STANDARD.
- 003700 01 STOCKING-REC.
- 003800 03 ADM-UNIT-D1.
- 003900 05 ST-D1 PIC X(02).
- 004000 05 DIS-D1 PIC X(02).
- 004100 05 RA-D1 PIC X(02).
- 004200 05 PLU-D1 PIC X(02).
- 004300 03 ALLOT-D1.
- 004400 05 ALLOT-NUM-D1 PIC X(04).
- 004500 05 PAST-NUM-D1 PIC X(02).
- 004600 03 STRATUM-D1 PIC X(04).
- 004700 03 RNG-SITE-D1 PIC X(11).
- 004800 03 SWA-D1 PIC X(04).
- 004900 03 COND-CLS-D1 PIC X(01).
- 005000 03 ACRES-SWA-TOT-D1 PIC 9(06).
- 005100 03 ACRES-OWNER-STRATUM-TOT-D1 PIC 9(06).
- 005200 03 ACRES-STRATUM-SUM-D1 PIC 9(06).
- 005300 03 PCT-OWNER-SWA-D1 PIC 9(03)V99.
- 005400 03 FILLER PIC XX.
- 005500 03 OWNER-D1 PIC X(04).
- 005600 03 JURIS-D1 PIC X(04).
- 005700 03 MGT-ADM-D1 PIC X(04).
- 005800 03 LAND-TYP-D1 PIC X(04).
- 005900 03 FILLER PIC X(03).
- 006000 03 STOCK-RATE-KEY-D1 PIC X.
- 006100 03 STOCKING-RATE-GRP-D1.
- 006200 05 STOCKING-RATE-D1 PIC X(05) OCCURS 5 TIMES.
- 006300 03 FILLER PIC X(04).
- 006400 FD ACRE-FILE
- 006500 CODE-SET IS GBCD
- 006600 LABEL RECORDS ARE STANDARD.
- 006700 01 ACRE-REC.
- 006800 03 REC-I1.
- 006900 05 REC-TYP-I1 PIC X(02).
- 007000 05 FMT-NUM-I1 PIC X.
- 007100 05 FMT-CD-I1 PIC X.
- 007200 03 ADM-UNIT-I1.
- 007300 05 ST-I1 PIC X(02).
- 007400 05 DIS-I1 PIC X(02).
- 007500 05 RA-I1 PIC X(02).
- 007600 05 PLU-I1 PIC X(02).
- 007700 03 ALLOT-I1.
- 007800 05 ALLOT-NUM-I1 PIC X(04).
- 007900 05 PAST-NUM-I1 PIC X(02).
- 008000 03 DATE-I1 PIC X(06).
- 008100 03 ACT-I1 PIC X(01).
- 008200 03 MAP-SRC-I1 PIC X(04).
- 008300 03 MTR-MER-CD-I1 PIC X(02).
- 008400 03 LINE-I1 PIC X(04).
- 008500 03 MTR-TWN-I1 PIC X(05).
- 008600 03 MTR-RNG-I1 PIC X(05).
- 008700 03 SEC-I1 PIC X(03).
- 008800 03 SWA-I1 PIC X(04).
- 008900 03 ALIQ-PART-I1 PIC X(16).
- 009000 03 ACRES-I1 PIC 9(05).
- 009100 03 OWNER-I1 PIC X(04).
- 009200 03 JURIS-I1 PIC X(04).
- 009300 03 MGT-ADM-I1 PIC X(04).
- 009400 03 LAND-TYP-I1 PIC X(04).
- 009500 03 FILLER PIC X(01).
- 009600 FD ACRE-WORK-FILE
- 009700 CODE-SET IS GBCD
- 009800 LABEL RECORD IS STANDARD.
- 009900 01 ACRE-WORK-REC.
- 010000 03 ADM-UNIT-W1.
- 010100 05 ST-W1 PIC X(02).
- 010200 05 DIS-W1 PIC X(02).
- 010300 05 RA-W1 PIC X(02).
- 010400 05 PLU-W1 PIC X(02).
- 010500 03 ALLOT-W1.
- 010600 05 ALLOT-NUM-W1 PIC X(04).
- 010700 05 PAST-NUM-W1 PIC X(02).
- 010800 03 SWA-W1 PIC X(04).
- 010900 03 ACRES-SWA-TOT-W1 PIC 9(06).
- 011000 03 ACRES-OWNER-TOT-W1 PIC 9(06).
- 011100 03 PCT-OWNER-SWA-W1 PIC 9(03)V99.
- 011200 03 FILLER PIC XX.
- 011300 03 OWNER-W1 PIC X(04).
- 011400 03 JURIS-W1 PIC X(04).
- 011500 03 MGT-ADM-W1 PIC X(04).
- 011600 03 LAND-TYP-W1 PIC X(04).
- 011700 03 FILLER PIC X.
- 011800 FD OWNER-WORK-FILE
- 011900 CODE-SET IS GBCD
- 012000 LABEL RECORD IS STANDARD.
- 012100 01 OWNER-WORK-REC.
- 012200 03 ADM-UNIT-W3.
- 012300 05 SD-W3.
- 012400 07 ST-W3 PIC X(02).
- 012500 07 DIS-W3 PIC X(02).
- 012600 05 RA-W3 PIC X(02).
- 012700 05 PLU-W3 PIC X(02).
- 012800 03 ALLOT-W3.
- 012900 05 ALLOT-NUM-W3 PIC X(04).
- 013000 05 PAST-NUM-W3 PIC X(02).
- 013100 03 STRATUM-W3 PIC X(04).
- 013200 03 RNG-SITE-W3 PIC X(11).
- 013300 03 SWA-W3 PIC X(04).
- 013400 03 COND-CLS-W3 PIC X(01).
- 013500 03 ACRES-SWA-TOT-W3 PIC 9(06).
- 013600 03 ACRES-OWNER-STRATUM-TOT-W3 PIC 9(06).
- 013700 03 ACRES-STRATUM-SUM-W3 PIC 9(06).
- 013800 03 PCT-OWNER-SWA-W3 PIC 9(03)V99.
- 013900 03 FILLER PIC XX.
- 014000 03 OWNER-W3 PIC X(04).
- 014100 03 JURIS-W3 PIC X(04).
- 014200 03 MGT-ADM-W3 PIC X(04).
- 014300 03 LAND-TYP-W3 PIC X(04).
- 014400 03 FILLER PIC X(03).
- 014500 FD STRATUM-FILE
- 014600 CODE-SET IS GBCD
- 014700 LABEL RECORD IS STANDARD.
- 014800 01 STRATUM-REC.
- 014900 03 ADM-UNIT-I2.
- 015000 05 ST-I2 PIC X(02).
- 015100 05 DIS-I2 PIC X(02).
- 015200 05 RA-I2 PIC X(02).
- 015300 05 PLU-I2 PIC X(02).
- 015400 03 SWAT-I2.
- 015500 05 SWA-I2 PIC X(4).
- 015600 05 TRANS-I2 PIC 99.
- 015700 03 RNG-SITE-I2 PIC X(11).
- 015800 03 STRATUM-I2 PIC 9(4).
- 015900 03 PCT-SWA-I2 PIC 9(03).
- 016000 03 ALLOT-I2.
- 016100 05 ALLOT-NUM-I2 PIC X(04).
- 016200 05 PAST-NUM-I2 PIC X(02).
- 016300 03 COMP-AREA-I2 PIC X.
- 016400 03 CLIM-ADJ-FCTR-I2 PIC 99V999.
- 016500 03 COND-CLS-I2 PIC X.
- 016600 03 FILLER PIC X(3).
- 016700 FD VM-FILE
- 016800 CODE-SET IS GBCD
- 016900 LABEL RECORD IS STANDARD.
- 017000 01 VM-REC.
- 017100 03 REC-I3.
- 017200 05 REC-TYP-I3 PIC X(02).
- 017300 05 FMT-NUM-I3 PIC X.
- 017400 05 FMT-CD-I3 PIC X.
- 017500 03 ADM-UNIT-I3.
- 017600 05 SD-I3.
- 017700 07 ST-I3 PIC X(02).
- 017800 07 DIS-I3 PIC X(02).
- 017900 03 DATE-I3 PIC X(06).
- 018000 03 ACT-I3 PIC X.
- 018100 03 STOCK-RATE-KEY-I3 PIC 9.
- 018200 03 RNG-SITE-I3 PIC X(11).
- 018300 03 STOCKING-RATE-GRP-I3.
- 018400 05 STOCKING-RATE-I3 PIC X(05) OCCURS 5 TIMES.
- 018500 03 FILLER PIC X(32).
- 018600 FD STRATUM-WORK-FILE
- 018700 CODE-SET IS GBCD
- 018800 LABEL RECORD IS STANDARD.
- 018900 01 STRATUM-WORK-REC.
- 019000 03 ADM-UNIT-W2.
- 019100 05 ST-W2 PIC X(02).
- 019200 05 DIS-W2 PIC X(02).
- 019300 05 RA-W2 PIC X(02).
- 019400 05 PLU-W2 PIC X(02).
- 019500 03 SWAT-W2.
- 019600 05 SWA-W2 PIC X(4).
- 019700 05 TRANS-W2 PIC 99.
- 019800 03 RNG-SITE-W2 PIC X(11).
- 019900 03 STRATUM-W2 PIC 9(4).
- 020000 03 PCT-SWA-TOT-W2 PIC 9(03).
- 020100 03 ALLOT-W2.
- 020200 05 ALLOT-NUM-W2 PIC X(04).
- 020300 05 PAST-NUM-W2 PIC X(02).
- 020400 03 COMP-AREA-I2 PIC X.
- 020500 03 CLIM-ADJ-FCTR-I2 PIC 99V999.
- 020600 03 COND-CLS-W2 PIC X.
- 020700 03 FILLER PIC X(03).
- 020800 SD SORT-FILE
- 020900 DATA RECORD IS SORT-REC.
- 021000 01 SORT-REC.
- 021100 03 SORT-KEY-SK1.
- 021200 05 ADM-UNIT-SK1 PIC X(08).
- 021300 05 ALLOT-SK1.
- 021400 07 ALLOT-NUM-SK1 PIC X(04).
- 021500 07 PAST-NUM-SK1 PIC X(02).
- 021600 05 SWA-SK1 PIC X(04).
- 021700 05 KEY-SK1 PIC 9.
- 021800 05 OWNER-SK1 PIC X(04).
- 021900 03 DATA-SK1.
- 022000 05 FILLER PIC X(68).
- 022100 05 ACRES-SK1 PIC 9(05).
- 022200 05 FILLER PIC X(17).
- 022300 SD SORT-FILE-2
- 022400 DATA RECORD IS SORT-REC-2.
- 022500 01 SORT-REC-2.
- 022600 03 SORT-KEY-SK2.
- 022700 05 ADM-UNIT-SK2 PIC X(08).
- 022800 05 ALLOT-SK2.
- 022900 07 ALLOT-NUM-SK2 PIC X(04).
- 023000 07 PAST-NUM-SK2 PIC X(02).
- 023100 05 STRATUM-SK2 PIC X(04).
- 023200 05 SWAT-SK2 PIC X(06).
- 023300 03 DATA-SK2 PIC X(48).
- 023400 SD SORT-FILE-3
- 023500 DATA RECORD IS SORT-REC-3.
- 023600 01 SORT-REC-3.
- 023700 03 SORT-KEY-SK3.
- 023800 05 SWA-CNTL-SK3.
- 023900 07 ADM-UNIT-SK3 PIC X(08).
- 024000 07 ALLOT-SK3.
- 024100 09 ALLOT-NUM-SK3 PIC X(04).
- 024200 09 PAST-NUM-SK3 PIC X(02).
- 024300 07 SWA-SK3 PIC X(04).
- 024400 05 STRATUM-SK3 PIC X(04).
- 024500 03 DATA-SK3.
- 024600 05 FILLER PIC X(29).
- 024700 05 PCT-SWA-TOT-SK3 PIC 9(03).
- 024800 05 FILLER PIC X(12).
- 024900 05 COND-CLS-SK3 PIC X.
- 025000 05 FILLER PIC X(03).
- 025100 SD SORT-FILE-4
- 025200 DATA RECORD IS SORT-REC-4.
- 025300 01 SORT-REC-4.
- 025400 03 SORT-KEY-SK4.
- 025500 05 CNTL-SK4.
- 025600 07 RNG-SITE-SK4 PIC X(11).
- 025700 07 STRATUM-SK4 PIC X(04).
- 025800 07 ALLOT-SK4.
- 025900 09 ALLOT-NUM-SK4 PIC X(04).
- 026000 09 PAST-NUM-SK4 PIC X(02).
- 026100 05 KEY-SK4 PIC 9.
- 026200 03 DATA-SK4.
- 026300 05 FILLER PIC X(46).
- 026400 05 ACRES-STRATUM-SUM-SK4 PIC 9(06).
- 026500 05 FILLER PIC X(56).
- 026600 WORKING-STORAGE SECTION.
- 026700 77 PAGE-NO COMP-4 PIC 9(6) VALUE 0.
- 026800 77 TEST-CNT-1 PIC 9(8) VALUE ZERO.
- 026900 77 TEST-CNT-2 PIC 9(8) VALUE ZERO.
- 027000 77 CNTL-SK4-HLD PIC X(21) VALUE SPACE.
- 027100 77 KEY-PREV PIC 9 VALUE ZERO.
- 027200 77 SK1-SW PIC 9 VALUE ZERO.
- 027300 77 SK2-SW PIC 9 VALUE ZERO.
- 027400 77 SK3-SW PIC 9 VALUE ZERO.
- 027500 77 END-SW PIC 9 VALUE ZERO.
- 027600 77 SUB PIC 99 VALUE ZERO.
- 027700 77 OWNER-SW PIC 9 VALUE ZERO.
- 027800 77 SWA-SW PIC 9 VALUE ZERO.
- 027900 77 X COMP-4 PIC 9 VALUE 0.
- 028000 77 Y COMP-4 PIC 9 VALUE 0.
- 028100 77 ACRES-SWA-TOT-HLD PIC 9(06) VALUE ZERO.
- 028200 77 ACRES-OWNER-TOT-HLD PIC 9(08) VALUE ZERO.
- 028300 77 ACRES-STRATUM-SUM-HLD PIC 9(06) VALUE ZERO.
- 028400 77 ACRES-OWNER-SWA-STRATUM-HLD PIC 9(06) VALUE ZERO.
- 028500 01 CNTL-W3-HLD.
- 028600 03 RNG-SITE-W3-HLD PIC X(11).
- 028700 03 STRATUM-W3-HLD PIC X(04).
- 028800 03 ALLOT-W3-HLD.
- 028900 05 ALLOT-NUM-W3-HLD PIC X(04).
- 029000 05 PAST-NUM-W3-HLD PIC X(02).
- 029100 01 PCT-SWA-STRATUM-TOT-HLD PIC 9(03)V99 VALUE ZERO.
- 029200 01 PCT-SWA-STRATUM-RD REDEFINES PCT-SWA-STRATUM-TOT-HLD
- 029300 PIC 9V9999.
- 029400 01 PCT-SWA-OWNER-HLD PIC 9(03)V99 VALUE ZERO.
- 029500 01 PCT-SWA-OWNER-RD REDEFINES PCT-SWA-OWNER-HLD
- 029600 PIC 9V9999.
- 029700 01 PCT-SWA-OWNER-STRATUM-HLD PIC 9(03)V99 VALUE ZERO.
- 029800 01 PCT-SWA-OWNER-STRATUM-RD REDEFINES PCT-SWA-OWNER-STRATUM-HLD
- 029900 PIC 9V9999.
- 030000 01 ACRE-CNTL-HLD.
- 030100 03 ADM-UNIT-ACRE-CNTL.
- 030200 05 ST-ACRE-CNTL PIC X(02).
- 030300 05 DIS-ACRE-CNTL PIC X(02).
- 030400 05 RA-ACRE-CNTL PIC X(02).
- 030500 05 PLU-ACRE-CNTL PIC X(02).
- 030600 03 ALLOT-ACRE-CNTL.
- 030700 05 ALLOT-NUM-ACRE-CNTL PIC X(04).
- 030800 05 PAST-NUM-ACRE-CNTL PIC X(02).
- 030900 03 SWA-ACRE-CNTL PIC X(04).
- 031000 01 STRATUM-CNTL-HLD.
- 031100 03 SWA-CNTL-HLD.
- 031200 05 ADM-UNIT-SWA-CNTL.
- 031300 07 ST-SWA-CNTL PIC X(02).
- 031400 07 DIS-SWA-CNTL PIC X(02).
- 031500 07 RA-SWA-CNTL PIC X(02).
- 031600 07 PLU-SWA-CNTL PIC X(02).
- 031700 05 ALLOT-SWA-CNTL.
- 031800 07 ALLOT-NUM-SWA-CNTL PIC X(04).
- 031900 07 PAST-NUM-SWA-CNTL PIC X(02).
- 032000 05 SWA-SWA-CNTL PIC X(04).
- 032100 03 STRATUM-SWA-CNTL PIC X(04).
- 032200 01 SWR-TABLE.
- 032300 03 SWR-TAB PIC X(48) OCCURS 30 TIMES.
- 032400 01 ACRE-SORT-REC-HLD.
- 032500 03 FILLER PIC X(04).
- 032600 03 ADM-UNIT-H1.
- 032700 05 ST-H1 PIC X(02).
- 032800 05 DIS-H1 PIC X(02).
- 032900 05 RA-H1 PIC X(02).
- 033000 05 PLU-H1 PIC X(02).
- 033100 03 ALLOT-H1.
- 033200 05 ALLOT-NUM-H1 PIC X(04).
- 033300 05 PAST-NUM-H1 PIC X(02).
- 033400 03 FILLER PIC X(30).
- 033500 03 SWA-H1 PIC X(04).
- 033600 03 FILLER PIC X(16).
- 033700 03 ACRES-H1 PIC 9(05).
- 033800 03 OWNER-H1 PIC X(04).
- 033900 03 JURIS-H1 PIC X(04).
- 034000 03 MGT-ADM-H1 PIC X(04).
- 034100 03 LAND-TYP-H1 PIC X(04).
- 034200 03 FILLER PIC X(01).
- 034300 01 STRATUM-SORT-REC-HLD.
- 034400 03 ADM-UNIT-H2.
- 034500 05 ST-H2 PIC X(02).
- 034600 05 DIS-H2 PIC X(02).
- 034700 05 RA-H2 PIC X(02).
- 034800 05 PLU-H2 PIC X(02).
- 034900 03 SWAT-H2.
- 035000 05 SWA-H2 PIC X(4).
- 035100 05 TRANS-H2 PIC 99.
- 035200 03 RNG-SITE-H2 PIC X(11).
- 035300 03 STRATUM-H2 PIC 9(4).
- 035400 03 PCT-SWA-H2 PIC 9(03).
- 035500 03 ALLOT-H2.
- 035600 05 ALLOT-NUM-H2 PIC X(04).
- 035700 05 PAST-NUM-H2 PIC X(02).
- 035800 03 COMP-AREA-H2 PIC X.
- 035900 03 CLIM-ADJ-FCTR-H2 PIC 99V999.
- 036000 03 COND-CLS-H2 PIC X.
- 036100 03 FILLER-H2 PIC X(3).
- 036200 01 VM-H3.
- 036300 03 REC-H3.
- 036400 05 REC-TYP-H3 PIC X(02).
- 036500 05 FMT-NUM-H3 PIC X.
- 036600 05 FMT-CD-H3 PIC X.
- 036700 03 ADM-UNIT-H3.
- 036800 05 ST-H3 PIC X(02).
- 036900 05 DIS-H3 PIC X(02).
- 037000 03 DATE-H3 PIC X(06).
- 037100 03 ACT-H3 PIC X.
- 037200 03 STOCK-RATE-KEY-H3 PIC 9.
- 037300 03 RNG-SITE-H3 PIC X(11).
- 037400 03 STOCKING-RATE-GRP-H3.
- 037500 05 STOCKING-RATE-H3 PIC X(05) OCCURS 5 TIMES.
- 037600 03 FILLER PIC X(32).
- 037700 01 STOCKING-REC-H5.
- 037800 03 OWNER-DATA.
- 037900 05 ADM-UNIT-H5.
- 038000 07 ST-H5 PIC X(02).
- 038100 07 DIS-H5 PIC X(02).
- 038200 07 RA-H5 PIC X(02).
- 038300 07 PLU-H5 PIC X(02).
- 038400 05 ALLOT-NUM-H5 PIC X(04).
- 038500 05 PAST-NUM-H5 PIC X(02).
- 038600 05 STRATUM-H5 PIC X(04).
- 038700 05 RNG-SITE-H5 PIC X(11).
- 038800 05 SWA-H5 PIC X(04).
- 038900 05 COND-CLS-H5 PIC X(01).
- 039000 05 ACRES-SWA-TOT-H5 PIC 9(06).
- 039100 05 ACRES-OWNER-STRATUM-TOT-H5 PIC 9(06).
- 039200 05 ACRES-STRATUM-SUM-H5 PIC 9(06).
- 039300 05 PCT-OWNER-SWA-H5 PIC 9(03)V99.
- 039400 05 FILLER PIC XX.
- 039500 05 OWNER-H5 PIC X(04).
- 039600 05 JURIS-H5 PIC X(04).
- 039700 05 MGT-ADM-H5 PIC X(04).
- 039800 05 LAND-TYP-H5 PIC X(04).
- 039900 05 FILLER PIC X(03).
- 040000 03 STOCK-RATE-KEY-H5 PIC 9.
- 040100 03 STOCKING-RATE-GRP-H5.
- 040200 05 STOCKING-RATE-H5 PIC X(05) OCCURS 5 TIMES.
- 040300 03 FILLER PIC X(4).
- 040400 01 HOLD-AREA.
- 040500 03 BLM-ADM-HOLD.
- 040600 05 ST-HOLD PIC XX.
- 040700 05 DT-HOLD PIC XX.
- 040800 05 RA-HOLD PIC XX.
- 040900 05 PLU-HOLD PIC XX.
- 041000 03 ALLOT-NUM-HOLD PIC X(4).
- 041100 03 PASTURE-NUM-HOLD PIC XX.
- 041200 03 MAP-SRC-HOLD PIC X(4).
- 041300 03 MTR-MER-CD-HOLD PIC XX.
- 041400 01 DATE-HOLD.
- 041500 03 YEAR-H PIC 99.
- 041600 03 MON-H PIC 99.
- 041700 03 DAY-H PIC 99.
- 041800 01 MONTH-TABLE PIC X(36) VALUE
- 041900 "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC".
- 042000 01 MONTH-LINE REDEFINES MONTH-TABLE.
- 042100 03 ALPHA-MONTH PIC X(3) OCCURS 12.
- 042200 01 HOLD-AREA.
- 042300 03 FUNC-HOLD.
- 042400 04 STATE-NAME PIC X(10).
- 042500 04 FILLER PIC X(14).
- 042600 03 EXPL-HOLD.
- 042700 04 DIST-NAME PIC X(10).
- 042800 04 FILLER PIC X.
- 042900 04 RA-NAME PIC X(12).
- 043000 04 FILLER PIC X.
- 043100 04 PLU-NAME PIC X(15).
- 043200 04 FILLER PIC X.
- 043300 03 DIST-H PIC XX.
- 043400 01 STOCK-RATE-HLD.
- 043500 03 SRH PIC X OCCURS 5 TIMES.
- 043600 COPY DBSTATUS OF TPCOBOLIB.
- 043700 PROCEDURE DIVISION.
- 043800 005-START SECTION.
- 043900 010-SORT-ACRES.
- 044000 SORT SORT-FILE ON ASCENDING KEY
- 044100 SORT-KEY-SK1
- 044200 INPUT PROCEDURE IS ACRE-SORT-INPUT
- 044300 OUTPUT PROCEDURE IS ACRE-SUM-OUTPUT.
- 044400 020-SORT-STRATUM.
- 044500 SORT SORT-FILE-2 ON ASCENDING KEY
- 044600 SORT-KEY-SK2
- 044700 INPUT PROCEDURE IS STRATUM-SORT-INPUT
- 044800 OUTPUT PROCEDURE IS STRATUM-SUM-OUTPUT.
- 044900 025-SORT-SWA.
- 045000 SORT SORT-FILE-3 ON ASCENDING KEY
- 045100 SORT-KEY-SK3
- 045200 INPUT PROCEDURE IS SWA-SORT-INPUT
- 045300 OUTPUT PROCEDURE IS OWNER-SUM-OUTPUT.
- 045400 027-SORT-OWNER-STOCKING.
- 045500 SORT SORT-FILE-4 ON ASCENDING KEY
- 045600 SORT-KEY-SK4
- 045700 INPUT PROCEDURE IS RNG-SITE-SORT-INPUT
- 045800 OUTPUT PROCEDURE IS STOCKING-SUM-OUTPUT.
- 045900 029-END.
- 046000 CLOSE STOCKING-FILE.
- 046100 DISPLAY "END JOB".
- 046200 STOP RUN.
- 046300 ACRE-SORT-INPUT SECTION.
- 046400 030-OPEN.
- 046500 OPEN INPUT ACRE-FILE.
- 046600 035-READ-ACRE.
- 046700 READ ACRE-FILE
- 046800 AT END GO TO 030-EXIT.
- 046900 IF PAST-NUM-I1 = SPACE
- 047000 MOVE ZERO TO PAST-NUM-I1.
- 047100* ADD 1 TO TEST-CNT-1.
- 047200* IF TEST-CNT-1 = 200 GO TO 030-EXIT.
- 047300* DISPLAY "AR = " ACRE-REC.
- 047400 MOVE ADM-UNIT-I1 TO ADM-UNIT-SK1.
- 047500 MOVE ALLOT-I1 TO ALLOT-SK1.
- 047600 MOVE SWA-I1 TO SWA-SK1.
- 047700 MOVE SPACE TO OWNER-SK1.
- 047800 MOVE ACRE-REC TO DATA-SK1.
- 047900 MOVE 1 TO KEY-SK1.
- 048000 RELEASE SORT-REC.
- 048100 MOVE ADM-UNIT-I1 TO ADM-UNIT-SK1.
- 048200 MOVE ALLOT-I1 TO ALLOT-SK1.
- 048300 MOVE SWA-I1 TO SWA-SK1.
- 048400 MOVE OWNER-I1 TO OWNER-SK1.
- 048500 MOVE ACRE-REC TO DATA-SK1.
- 048600 MOVE 2 TO KEY-SK1.
- 048700 RELEASE SORT-REC.
- 048800 GO TO 035-READ-ACRE.
- 048900 030-EXIT.
- 049000 EXIT.
- 049100 ACRE-SUM-OUTPUT SECTION.
- 049200 040-OPEN.
- 049300 OPEN OUTPUT ACRE-WORK-FILE.
- 049400 INITIALIZE ACRE-SORT-REC-HLD.
- 049500 INITIALIZE ACRE-WORK-REC.
- 049600 CLOSE ACRE-FILE.
- 049700 045-RETURN.
- 049800 RETURN SORT-FILE
- 049900 AT END
- 050000 MOVE 1 TO SK1-SW
- 050100 GO TO 050-SUM.
- 050200* DISPLAY "SR1= " SORT-REC.
- 050300 IF ADM-UNIT-H1 = SPACE
- 050400 MOVE ADM-UNIT-SK1 TO ADM-UNIT-H1
- 050500 MOVE ALLOT-SK1 TO ALLOT-H1
- 050600 MOVE SWA-SK1 TO SWA-H1.
- 050700 IF (ADM-UNIT-SK1 NOT = ADM-UNIT-H1) OR
- 050800 (ALLOT-SK1 NOT = ALLOT-H1) OR
- 050900 (SWA-SK1 NOT = SWA-H1)
- 051000 GO TO 050-SUM.
- 051100 IF KEY-SK1 = 1
- 051200 ADD ACRES-SK1 TO ACRES-SWA-TOT-HLD
- 051300 GO TO 045-RETURN.
- 051400 IF OWNER-H1 = SPACE
- 051500 MOVE OWNER-SK1 TO OWNER-H1.
- 051600 IF OWNER-SK1 = OWNER-H1
- 051700 ADD ACRES-SK1 TO ACRES-OWNER-TOT-HLD
- 051800 MOVE DATA-SK1 TO ACRE-SORT-REC-HLD
- 051900 GO TO 045-RETURN.
- 052000 MOVE 1 TO OWNER-SW.
- 052100 050-SUM.
- 052200 MOVE ADM-UNIT-H1 TO ADM-UNIT-W1.
- 052300 MOVE ALLOT-NUM-H1 TO ALLOT-NUM-W1.
- 052400 MOVE PAST-NUM-H1 TO PAST-NUM-W1.
- 052500 MOVE SWA-H1 TO SWA-W1.
- 052600 MOVE OWNER-H1 TO OWNER-W1.
- 052700 MOVE JURIS-H1 TO JURIS-W1.
- 052800 MOVE MGT-ADM-H1 TO MGT-ADM-W1.
- 052900 MOVE LAND-TYP-H1 TO LAND-TYP-W1.
- 053000 MOVE ACRES-OWNER-TOT-HLD TO ACRES-OWNER-TOT-W1.
- 053100 MOVE ACRES-SWA-TOT-HLD TO ACRES-SWA-TOT-W1.
- 053200 MULTIPLY 100 BY ACRES-OWNER-TOT-HLD.
- 053300 DIVIDE ACRES-OWNER-TOT-HLD BY
- 053400 ACRES-SWA-TOT-HLD GIVING PCT-OWNER-SWA-W1 ROUNDED.
- 053500 MOVE ZERO TO ACRES-OWNER-TOT-HLD.
- 053600* DISPLAY "AWR= " ACRE-WORK-REC.
- 053700 WRITE ACRE-WORK-REC.
- 053800 INITIALIZE ACRE-WORK-REC.
- 053900 IF SK1-SW = 1 GO TO 040-EXIT.
- 054000 IF OWNER-SW = 1
- 054100 MOVE ZERO TO OWNER-SW
- 054200 MOVE ACRES-SK1 TO ACRES-OWNER-TOT-HLD
- 054300 MOVE DATA-SK1 TO ACRE-SORT-REC-HLD
- 054400 GO TO 045-RETURN.
- 054500 MOVE ACRES-SK1 TO ACRES-SWA-TOT-HLD.
- 054600 MOVE DATA-SK1 TO ACRE-SORT-REC-HLD.
- 054700 MOVE SPACE TO OWNER-H1.
- 054800 GO TO 045-RETURN.
- 054900 040-EXIT.
- 055000 EXIT.
- 055100 STRATUM-SORT-INPUT SECTION.
- 055200 060-OPEN.
- 055300 OPEN INPUT STRATUM-FILE.
- 055400 CLOSE ACRE-WORK-FILE.
- 055500 060-READ-STRATUM.
- 055600 READ STRATUM-FILE
- 055700 AT END GO TO 060-EXIT.
- 055800 IF PAST-NUM-I2 = SPACE
- 055900 MOVE ZERO TO PAST-NUM-I2.
- 056000* ADD 1 TO TEST-CNT-2.
- 056100* IF TEST-CNT-2 = 200 GO TO 060-EXIT.
- 056200* DISPLAY "STRAT-REC= " STRATUM-REC.
- 056300 MOVE ADM-UNIT-I2 TO ADM-UNIT-SK2.
- 056400 MOVE ALLOT-I2 TO ALLOT-SK2.
- 056500 MOVE SWAT-I2 TO SWAT-SK2.
- 056600 MOVE STRATUM-I2 TO STRATUM-SK2.
- 056700 MOVE STRATUM-REC TO DATA-SK2.
- 056800 RELEASE SORT-REC-2.
- 056900 GO TO 060-READ-STRATUM.
- 057000 060-EXIT.
- 057100 EXIT.
- 057200 STRATUM-SUM-OUTPUT SECTION.
- 057300 070-OPEN.
- 057400 OPEN OUTPUT STRATUM-WORK-FILE.
- 057500 CLOSE STRATUM-FILE.
- 057600 INITIALIZE STRATUM-SORT-REC-HLD.
- 057700 075-RETURN.
- 057800 RETURN SORT-FILE-2
- 057900 AT END
- 058000 MOVE 1 TO SK2-SW
- 058100 GO TO 075-SUM.
- 058200* DISPLAY "SR2= " SORT-REC-2.
- 058300 IF ADM-UNIT-H2 = SPACE
- 058400 MOVE ADM-UNIT-SK2 TO ADM-UNIT-H2
- 058500 MOVE ALLOT-SK2 TO ALLOT-H2
- 058600 MOVE STRATUM-SK2 TO STRATUM-H2.
- 058700 IF (ADM-UNIT-SK2 NOT = ADM-UNIT-H2) OR
- 058800 (ALLOT-SK2 NOT = ALLOT-H2) OR
- 058900 (STRATUM-SK2 NOT = STRATUM-H2)
- 059000 GO TO 075-SUM.
- 059100 IF SWA-H2 = SPACE
- 059200 MOVE SWAT-SK2 TO SWAT-H2.
- 059300 IF SWAT-SK2 = SWAT-H2
- 059400 MOVE DATA-SK2 TO STRATUM-SORT-REC-HLD
- 059500 ADD PCT-SWA-H2 TO PCT-SWA-STRATUM-TOT-HLD
- 059600 GO TO 075-RETURN.
- 059700 075-SUM.
- 059800 MOVE STRATUM-SORT-REC-HLD TO STRATUM-WORK-REC.
- 059900 MOVE PCT-SWA-STRATUM-TOT-HLD TO PCT-SWA-TOT-W2.
- 060000* DISPLAY "SWR= " STRATUM-WORK-REC.
- 060100 WRITE STRATUM-WORK-REC.
- 060200 IF SK2-SW = 1
- 060300 GO TO 070-EXIT.
- 060400 MOVE DATA-SK2 TO STRATUM-SORT-REC-HLD.
- 060500 MOVE PCT-SWA-H2 TO PCT-SWA-STRATUM-TOT-HLD.
- 060600 GO TO 075-RETURN.
- 060700 070-EXIT.
- 060800 EXIT.
- 060900 SWA-SORT-INPUT SECTION.
- 061000 080-OPEN.
- 061100 CLOSE STRATUM-WORK-FILE.
- 061200 OPEN INPUT STRATUM-WORK-FILE.
- 061300 080-READ-SWA.
- 061400 READ STRATUM-WORK-FILE
- 061500 AT END GO TO 080-EXIT.
- 061600* DISPLAY "SWR= " STRATUM-WORK-REC.
- 061700 MOVE ADM-UNIT-W2 TO ADM-UNIT-SK3.
- 061800 MOVE ALLOT-W2 TO ALLOT-SK3.
- 061900 MOVE SWA-W2 TO SWA-SK3.
- 062000 MOVE STRATUM-W2 TO STRATUM-SK3.
- 062100 MOVE STRATUM-WORK-REC TO DATA-SK3.
- 062200 RELEASE SORT-REC-3.
- 062300 GO TO 080-READ-SWA.
- 062400 080-EXIT.
- 062500 EXIT.
- 062600 OWNER-SUM-OUTPUT SECTION.
- 062700 090-OPEN.
- 062800 CLOSE STRATUM-WORK-FILE.
- 062900 OPEN OUTPUT OWNER-WORK-FILE.
- 063000 MOVE SPACE TO ACRE-CNTL-HLD STRATUM-CNTL-HLD.
- 063100 MOVE SPACE TO SWR-TABLE.
- 063200 OPEN INPUT ACRE-WORK-FILE.
- 063300 095-RETURN.
- 063400 RETURN SORT-FILE-3
- 063500 AT END
- 063600 MOVE 1 TO SK3-SW
- 063700 GO TO 098-PASS.
- 063800* DISPLAY "SR3= " SORT-REC-3.
- 063900 IF SUB > 29 DISPLAY "SWA TABLE OVERSIZE SUB = " SUB
- 064000 CALL "ABORT".
- 064100 097-LOAD.
- 064200 IF SK3-SW = 1 GO TO 105-CHK-END.
- 064300 IF STRATUM-CNTL-HLD = SPACE
- 064400 MOVE ADM-UNIT-SK3 TO ADM-UNIT-SWA-CNTL
- 064500 MOVE ALLOT-SK3 TO ALLOT-SWA-CNTL
- 064600 MOVE SWA-SK3 TO SWA-SWA-CNTL
- 064700 MOVE STRATUM-SK3 TO STRATUM-SWA-CNTL
- 064800 ADD 1 TO SUB
- 064900 MOVE DATA-SK3 TO SWR-TAB (SUB)
- 065000 GO TO 095-RETURN.
- 065100* DISPLAY "SCH= " STRATUM-CNTL-HLD.
- 065200 IF STRATUM-CNTL-HLD = SORT-KEY-SK3
- 065300 GO TO 095-RETURN.
- 065400 IF SWA-CNTL-HLD = SWA-CNTL-SK3
- 065500 MOVE STRATUM-SK3 TO STRATUM-SWA-CNTL
- 065600 ADD 1 TO SUB
- 065700 MOVE DATA-SK3 TO SWR-TAB (SUB)
- 065800 GO TO 095-RETURN.
- 065900 098-PASS.
- 066000 IF SWA-CNTL-HLD = ACRE-CNTL-HLD
- 066100 GO TO 100-MOVE-OWNER-WORK.
- 066200 100-READ-ACRE-WORK.
- 066300 READ ACRE-WORK-FILE
- 066400 AT END
- 066500 MOVE 1 TO END-SW
- 066600 GO TO 100-EXIT.
- 066700* DISPLAY "AWR= " ACRE-WORK-REC.
- 066800 MOVE ADM-UNIT-W1 TO ADM-UNIT-ACRE-CNTL.
- 066900 MOVE ALLOT-W1 TO ALLOT-ACRE-CNTL.
- 067000 MOVE SWA-W1 TO SWA-ACRE-CNTL.
- 067100 IF ACRE-CNTL-HLD > SWA-CNTL-HLD
- 067200 MOVE ZERO TO SUB
- 067300 MOVE SPACE TO SWR-TABLE STRATUM-CNTL-HLD
- 067400 GO TO 097-LOAD.
- 067500 IF ACRE-CNTL-HLD < SWA-CNTL-HLD
- 067600 DISPLAY "ACH= " ACRE-CNTL-HLD
- 067700 DISPLAY "SCH= " SWA-CNTL-HLD
- 067800 GO TO 100-READ-ACRE-WORK.
- 067900 100-MOVE-OWNER-WORK.
- 068000 MOVE ZERO TO SUB.
- 068100 100-LOOP.
- 068200 MOVE SPACE TO OWNER-WORK-REC.
- 068300 MOVE ADM-UNIT-W1 TO ADM-UNIT-W3.
- 068400 MOVE ALLOT-NUM-W1 TO ALLOT-NUM-W3.
- 068500 MOVE PAST-NUM-W1 TO PAST-NUM-W3.
- 068600 MOVE SWA-W1 TO SWA-W3.
- 068700 MOVE OWNER-W1 TO OWNER-W3.
- 068800 MOVE JURIS-W1 TO JURIS-W3.
- 068900 MOVE MGT-ADM-W1 TO MGT-ADM-W3.
- 069000 MOVE LAND-TYP-W1 TO LAND-TYP-W3.
- 069100 MOVE PCT-OWNER-SWA-W1 TO PCT-SWA-OWNER-HLD.
- 069200 MOVE ACRES-SWA-TOT-W1 TO ACRES-SWA-TOT-W3.
- 069300 ADD 1 TO SUB.
- 069400 IF SWR-TAB (SUB) = SPACE
- 069500 GO TO 100-READ-ACRE-WORK.
- 069600 MOVE SWR-TAB (SUB) TO STRATUM-SORT-REC-HLD.
- 069700 MOVE STRATUM-H2 TO STRATUM-W3.
- 069800 MOVE RNG-SITE-H2 TO RNG-SITE-W3.
- 069900 MOVE COND-CLS-H2 TO COND-CLS-W3.
- 070000 MOVE PCT-SWA-H2 TO PCT-SWA-STRATUM-TOT-HLD.
- 070100 MULTIPLY PCT-SWA-OWNER-RD BY PCT-SWA-STRATUM-RD
- 070200 GIVING PCT-SWA-OWNER-STRATUM-RD ROUNDED.
- 070300 MULTIPLY ACRES-SWA-TOT-W1 BY PCT-SWA-OWNER-STRATUM-RD
- 070400 GIVING ACRES-OWNER-SWA-STRATUM-HLD ROUNDED.
- 070500 MOVE ACRES-OWNER-SWA-STRATUM-HLD TO
- 070600 ACRES-OWNER-STRATUM-TOT-W3.
- 070700 MOVE PCT-SWA-OWNER-STRATUM-HLD TO
- 070800 PCT-OWNER-SWA-W3.
- 070900* DISPLAY "OWR= " OWNER-WORK-REC.
- 071000 WRITE OWNER-WORK-REC.
- 071100 GO TO 100-LOOP.
- 071200 100-EXIT.
- 071300 EXIT.
- 071400 105-CHK-END.
- 071500 IF END-SW NOT = 1
- 071600 DISPLAY "ACRES-WORK-FILE NOT AT END"
- 071700 STOP RUN.
- 071800 090-EXIT.
- 071900 EXIT.
- 072000 RNG-SITE-SORT-INPUT SECTION.
- 072100 110-OPEN.
- 072200 CLOSE OWNER-WORK-FILE.
- 072300 CLOSE ACRE-WORK-FILE.
- 072400 OPEN INPUT OWNER-WORK-FILE.
- 072500 OPEN INPUT VM-FILE.
- 072600 110-READ-OWNER.
- 072700 READ OWNER-WORK-FILE AT END
- 072800 MOVE SPACE TO SORT-REC-4
- 072900 GO TO 115-RELEASE-TOTAL.
- 073000* DISPLAY "OWR= " STRATUM-WORK-REC.
- 073100 MOVE RNG-SITE-W3 TO RNG-SITE-W3-HLD.
- 073200 MOVE ALLOT-W3 TO ALLOT-W3-HLD.
- 073300 MOVE STRATUM-W3 TO STRATUM-W3-HLD.
- 073400 MOVE ALLOT-NUM-W3 TO ALLOT-NUM-W3-HLD.
- 073500 MOVE PAST-NUM-W3 TO PAST-NUM-W3-HLD.
- 073600 IF CNTL-SK4-HLD = SPACE
- 073700 MOVE CNTL-W3-HLD TO CNTL-SK4-HLD.
- 073800 IF CNTL-W3-HLD NOT = CNTL-SK4-HLD
- 073900 PERFORM 115-RELEASE-TOTAL
- 074000 MOVE CNTL-W3-HLD TO CNTL-SK4-HLD.
- 074100 MOVE 2 TO KEY-SK4.
- 074200 MOVE OWNER-WORK-REC TO DATA-SK4.
- 074300 MOVE CNTL-W3-HLD TO CNTL-SK4.
- 074400 ADD ACRES-OWNER-STRATUM-TOT-W3 TO ACRES-STRATUM-SUM-HLD.
- 074500 RELEASE SORT-REC-4.
- 074600 GO TO 110-READ-OWNER.
- 074700 115-RELEASE-TOTAL.
- 074800 MOVE SPACE TO SORT-REC-4.
- 074900 MOVE 0 TO KEY-SK4.
- 075000 MOVE CNTL-SK4-HLD TO CNTL-SK4.
- 075100 MOVE ACRES-STRATUM-SUM-HLD TO ACRES-STRATUM-SUM-SK4.
- 075200 MOVE ZERO TO ACRES-STRATUM-SUM-HLD.
- 075300 RELEASE SORT-REC-4.
- 075400 110-EXIT.
- 075500 EXIT.
- 075600 120-READ-VM.
- 075700 READ VM-FILE
- 075800 AT END GO TO 120-EXIT.
- 075900 MOVE RNG-SITE-I3 TO RNG-SITE-SK4.
- 076000 MOVE ZERO TO STRATUM-SK4 ALLOT-SK4.
- 076100 MOVE 1 TO KEY-SK4.
- 076200 MOVE ZERO TO X Y.
- 076300 121-LP.
- 076400 IF X = 5 GO TO 123-RELEASE.
- 076500 ADD 1 TO X.
- 076600 MOVE STOCKING-RATE-I3 (X) TO STOCK-RATE-HLD.
- 076700 122-LP.
- 076800 IF Y = 5
- 076900 MOVE STOCK-RATE-HLD TO STOCKING-RATE-I3 (X)
- 077000 MOVE ZERO TO Y
- 077100 GO TO 121-LP.
- 077200 IF SRH (Y) = SPACE MOVE ZERO TO SRH (Y).
- 077300 ADD 1 TO Y.
- 077400 GO TO 122-LP.
- 077500 123-RELEASE.
- 077600 MOVE VM-REC TO DATA-SK4.
- 077700 RELEASE SORT-REC-4.
- 077800 GO TO 120-READ-VM.
- 077900 120-EXIT.
- 078000 EXIT.
- 078100 STOCKING-SUM-OUTPUT SECTION.
- 078200 130-OPEN.
- 078300 OPEN OUTPUT STOCKING-FILE.
- 078400 MOVE SPACE TO STOCKING-REC-H5
- 078500 130-RETURN.
- 078600 RETURN SORT-FILE-4
- 078700 AT END
- 078800 GO TO 130-EXIT.
- 078900* ADD 1 TO TEST-CNT-1.
- 079000* IF TEST-CNT-1 < 300
- 079100* DISPLAY "SR4= " SORT-REC-4.
- 079200 IF (KEY-PREV = 2 OR 1) AND
- 079300 (KEY-SK4 = ZERO)
- 079400 MOVE ZERO TO ACRES-STRATUM-SUM-HLD.
- 079500 MOVE KEY-SK4 TO KEY-PREV.
- 079600 IF KEY-SK4 = 0
- 079700 ADD ACRES-STRATUM-SUM-SK4 TO ACRES-STRATUM-SUM-HLD
- 079800 GO TO 130-RETURN.
- 079900 IF (KEY-SK4 = 1) AND
- 080000 (RNG-SITE-SK4 = RNG-SITE-H5)
- 080100 DISPLAY "VM - DUPLICATE RNG-SITE= " DATA-SK4
- 080200 GO TO 130-RETURN.
- 080300 IF KEY-SK4 = 1
- 080400 MOVE DATA-SK4 TO VM-H3
- 080500 MOVE SPACE TO STOCKING-REC-H5
- 080600 MOVE RNG-SITE-SK4 TO RNG-SITE-H5
- 080700 MOVE STOCKING-RATE-GRP-H3 TO STOCKING-RATE-GRP-H5
- 080800 MOVE STOCK-RATE-KEY-H3 TO STOCK-RATE-KEY-H5
- 080900 GO TO 130-RETURN.
- 081000 IF RNG-SITE-SK4 NOT = RNG-SITE-H5
- 081100 MOVE SPACE TO STOCKING-REC-H5.
- 081200 MOVE DATA-SK4 TO OWNER-DATA.
- 081300 MOVE ACRES-STRATUM-SUM-HLD TO ACRES-STRATUM-SUM-H5.
- 081400 WRITE STOCKING-REC FROM STOCKING-REC-H5.
- 081500 GO TO 130-RETURN.
- 081600 130-EXIT.
- 081700 EXIT.
- 081800 DUMMY SECTION.
- 081900 999-END.
- 000000*-----------------------------------------------------------------
- 000100 IDENTIFICATION DIVISION.
- 000200 PROGRAM-ID. ES526P.
- 000300* ECOLOGICAL CONDITION CLASS/EST. STOCKING RATE (P01B).
- 000400*
- 000500 AUTHOR. RON BAKER.
- 000600 INSTALLATION. BLM.
- 000700 DATE-WRITTEN. NOV 1981.
- 000800 ENVIRONMENT DIVISION.
- 000900 CONFIGURATION SECTION.
- 001000 SOURCE-COMPUTER. LEVEL-66-ASCII.
- 001100 OBJECT-COMPUTER. LEVEL-66-ASCII SEQUENCE IS EBCDIC.
- 001200 INPUT-OUTPUT SECTION.
- 001300 FILE-CONTROL.
- 001400 SELECT VM-COND-LIST-FILE ASSIGN P1
- 001500 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001600 SELECT RNG-SITE-WORK-FILE ASSIGN W1
- 001700 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 001800 SELECT STOCKING-FILE ASSIGN TO I1
- 001900 ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
- 002000 SELECT SORT-FILE ASSIGN TO S1 S2 S3.
- 002100 SELECT SORT-FILE-2 ASSIGN TO S1 S2 S3.
- 002200 DATA DIVISION.
- 002300 SUB-SCHEMA SECTION.
- 002400 DB CODVAL2 WITHIN BLMDIC.
- 002500 FILE SECTION.
- 002600 FD STOCKING-FILE
- 002700 CODE-SET IS GBCD
- 002800 LABEL RECORD IS STANDARD.
- 002900 01 STOCKING-REC.
- 003000 03 ADM-UNIT-I1.
- 003100 05 ST-I1 PIC X(02).
- 003200 05 DIS-I1 PIC X(02).
- 003300 05 RA-I1 PIC X(02).
- 003400 05 PLU-I1 PIC X(02).
- 003500 03 ALLOT-I1.
- 003600 05 ALLOT-NUM-I1 PIC X(04).
- 003700 05 PAST-NUM-I1 PIC X(02).
- 003800 03 STRATUM-I1 PIC X(04).
- 003900 03 RNG-SITE-I1 PIC X(11).
- 004000 03 SWA-I1 PIC X(04).
- 004100 03 COND-CLS-I1 PIC X(01).
- 004200 03 ACRES-SWA-TOT-I1 PIC 9(06).
- 004300 03 ACRES-OWNER-STRATUM-TOT-I1 PIC 9(06).
- 004400 03 ACRES-STRATUM-SUM-I1 PIC 9(06).
- 004500 03 PCT-OWNER-SWA-I1 PIC 9(03)V99.
- 004600 03 FILLER PIC XX.
- 004700 03 OWNER-I1 PIC X(04).
- 004800 03 JURIS-I1 PIC X(04).
- 004900 03 MGT-ADM-I1 PIC X(04).
- 005000 03 LAND-TYP-I1 PIC X(04).
- 005100 03 FILLER PIC X(03).
- 005200 03 STOCK-RATE-KEY-I1 PIC 9.
- 005300 03 STOCKING-RATE-GRP-I1.
- 005400 05 STOCKING-RATE-I1 PIC X(05) OCCURS 5 TIMES.
- 005500 03 FILLER PIC X(04).
- 005600 FD RNG-SITE-WORK-FILE
- 005700 CODE-SET IS GBCD
- 005800 LABEL RECORD IS STANDARD.
- 005900 01 RNG-SITE-WORK-REC.
- 006000 03 ADM-UNIT-W1.
- 006100 05 ST-W1 PIC X(02).
- 006200 05 DIS-W1 PIC X(02).
- 006300 05 RA-W1 PIC X(02).
- 006400 05 PLU-W1 PIC X(02).
- 006500 03 ALLOT-W1.
- 006600 05 ALLOT-NUM-W1 PIC X(04).
- 006700 05 PAST-NUM-W1 PIC X(02).
- 006800 03 RNG-SITE-W1 PIC X(11).
- 006900 03 OWNER-W1 PIC X(04).
- 007000 03 ACRES-W1 PIC 9(07).
- 007100 03 EST-AUMS-PRES-W1 PIC 9(7)V99.
- 007200 03 EST-AUMS-POTN-W1 PIC 9(7)V99.
- 007300 03 COND-SUB-W1 PIC 9.
- 007400 03 FILLER PIC X(05).
- 007500 FD VM-COND-LIST-FILE
- 007600 CODE-SET IS GBCD
- 007700 LABEL RECORDS ARE STANDARD
- 007800 DATA RECORD IS VM-COND-LIST-FILE.
- 007900 01 VM-COND-LIST-REC PIC X(132).
- 008000 SD SORT-FILE
- 008100 DATA RECORD IS SORT-REC.
- 008200 01 SORT-REC.
- 008300 03 SORT-KEY.
- 008400 05 ADM-UNIT-SK1 PIC X(08).
- 008500 05 ALLOT-SK1.
- 008600 07 ALLOT-NUM-SK1 PIC X(04).
- 008700 07 PAST-NUM-SK1 PIC XX.
- 008800 05 STRATUM-SK1 PIC X(04).
- 008900 05 OWNER-SK1 PIC X(04).
- 009000 05 RNG-SITE-SK1 PIC X(11).
- 009100 03 DATA-SK1 PIC X(102).
- 009200 SD SORT-FILE-2
- 009300 DATA RECORD IS SORT-REC-2.
- 009400 01 SORT-REC-2.
- 009500 03 SORT-KEY-2.
- 009600 05 KEY-SK2 PIC 9.
- 009700 05 ADM-UNIT-SK2 PIC X(08).
- 009800 05 ALLOT-SK2.
- 009900 07 ALLOT-NUM-SK2 PIC X(04).
- 010000 07 PAST-NUM-SK2 PIC XX.
- 010100 05 RNG-SITE-SK2.
- 010200 07 OWNER-SK2 PIC X(04).
- 010300 07 COND-SUB-SK2 PIC 9.
- 010400 07 FILLER PIC X(06).
- 010500 03 DATA-SK2 PIC X(60).
- 010600 WORKING-STORAGE SECTION.
- 010700 77 PG-CNT PIC 9(5) VALUE ZERO.
- 010800 77 LINE-HLD PIC 9 VALUE 1.
- 010900 77 LINE-CNT PIC 9(2) VALUE 99.
- 011000 77 END-SW PIC 9 VALUE ZERO.
- 011100 77 INV-SW PIC 9 VALUE ZERO.
- 011200 77 ADM-SW PIC 9 VALUE ZERO.
- 011300 77 RNG-SW PIC 9 VALUE ZERO.
- 011400 77 OWN-SW PIC 9 VALUE ZERO.
- 011500 77 END-OWN-SW PIC 9 VALUE ZERO.
- 011600 77 END-OWN2-SW PIC 9 VALUE ZERO.
- 011700 77 COND-SW PIC 9 VALUE ZERO.
- 011800 77 COND-SUB PIC 9 VALUE ZERO.
- 011900 77 END-RNG-SW PIC 9 VALUE ZERO.
- 012000 77 END-RNG2-SW PIC 9 VALUE ZERO.
- 012100 77 OFLO-SW PIC 9 VALUE 1.
- 012200 77 SDRP-SW PIC 9 VALUE 1.
- 012300 77 SUB PIC 9 VALUE ZERO.
- 012400 77 OWNER-P4-HLD PIC X(04) VALUE SPACE.
- 012500 77 INVENTORY PIC X(04).
- 012600 77 RNG-SITE-PREV-HLD PIC X(11).
- 012700 77 COND-CLS-PREV-HLD PIC X(01).
- 012800 77 STRATUM-PREV-HLD PIC X(04).
- 012900 01 TOT-CNTL.
- 013000 03 ADM-UNIT-CNTL PIC X(08).
- 013100 03 ALLOT-CNTL.
- 013200 05 ALLOT-NUM-CNTL PIC X(04).
- 013300 05 PAST-NUM-CNTL PIC XX.
- 013400 03 STRATUM-CNTL PIC X(04).
- 013500 03 OWNER-CNTL PIC X(04).
- 013600 03 RNG-SITE-CNTL PIC X(11).
- 013700 01 RNG-CNTL.
- 013800 03 KEY-RNG-CNTL PIC 9.
- 013900 03 ADM-UNIT-RNG-CNTL PIC X(08).
- 014000 03 ALLOT-RNG-RNG-CNTL.
- 014100 05 ALLOT-RNG-CNTL.
- 014200 07 ALLOT-NUM-RNG-CNTL PIC X(04).
- 014300 07 PAST-NUM-RNG-CNTL PIC XX.
- 014400 03 RNG-SITE-RNG-CNTL.
- 014500 07 OWNER-RNG-CNTL PIC X(04).
- 014600 07 COND-SUB-RNG-CNTL PIC 9.
- 014700 07 FILLER PIC X(06).
- 014800 01 ALLOT-P3-HLD.
- 014900 03 ALLOT-NUM-P3-HLD PIC X(04).
- 015000 03 PAST-NUM-P3-HLD PIC X(02).
- 015100 01 TOTALS-HLD.
- 015200 03 ACRES-CAL PIC 9(09) VALUE ZERO.
- 015300 03 PCT-CAL PIC 999 VALUE ZERO.
- 015400 03 ACRES-PLU-SUM PIC 9(07) VALUE ZERO.
- 015500 03 ACRES-INV-SUM PIC 9(07) VALUE ZERO.
- 015600 03 ACRES-COND-TOT PIC 9(07) VALUE ZERO.
- 015700 03 AUMS-PRES-COND-TOT PIC 9(7)V99 VALUE ZERO.
- 015800 03 AUMS-POTN-COND-TOT PIC 9(07)V99 VALUE ZERO.
- 015900 03 ACRES-SWA-OWNER-TOT PIC 9(07) VALUE ZERO.
- 016000 03 ACRES-OWNER-TOT PIC 9(07) VALUE ZERO.
- 016100 03 AUMS-PRES-OWNER-TOT PIC 9(7)V99 VALUE ZERO.
- 016200 03 AUMS-POTN-OWNER-TOT PIC 9(07)V99 VALUE ZERO.
- 016300 03 ACRES-STRATUM-TOT PIC 9(07) VALUE ZERO.
- 016400 03 AUMS-PRES-STRATUM-TOT PIC 9(7)V99 VALUE ZERO.
- 016500 03 AUMS-POTN-STRATUM-TOT PIC 9(07)V99 VALUE ZERO.
- 016600 03 ACRES-RNG-SITE-TOT PIC 9(07) VALUE ZERO.
- 016700 03 AUMS-PRES-RNG-SITE-TOT PIC 9(7)V99 VALUE ZERO.
- 016800 03 AUMS-POTN-RNG-SITE-TOT PIC 9(07)V99 VALUE ZERO.
- 016900 03 ACRES-PAST-TOT PIC 9(07) VALUE ZERO.
- 017000 03 AUMS-PRES-PAST-TOT PIC 9(7)V99 VALUE ZERO.
- 017100 03 AUMS-POTN-PAST-TOT PIC 9(07)V99 VALUE ZERO.
- 017200 03 ACRES-ALOT-TOT PIC 9(07) VALUE ZERO.
- 017300 03 AUMS-PRES-ALOT-TOT PIC 9(7)V99 VALUE ZERO.
- 017400 03 AUMS-POTN-ALOT-TOT PIC 9(07)V99 VALUE ZERO.
- 017500 03 ACRES-PLU-TOT PIC 9(07) VALUE ZERO.
- 017600 03 AUMS-PRES-PLU-TOT PIC 9(7)V99 VALUE ZERO.
- 017700 03 AUMS-POTN-PLU-TOT PIC 9(07)V99 VALUE ZERO.
- 017800 03 ACRES-INV-TOT PIC 9(07) VALUE ZERO.
- 017900 03 AUMS-PRES-INV-TOT PIC 9(7)V99 VALUE ZERO.
- 018000 03 AUMS-POTN-INV-TOT PIC 9(07)V99 VALUE ZERO.
- 018100 03 PCT-OWNER-TOT PIC 9V99 VALUE ZERO.
- 018200 03 PCT-OWNER-TOT-RD REDEFINES PCT-OWNER-TOT
- 018300 PIC 999.
- 018400 01 COND-SUM-TOTALS.
- 018500 03 COND-PLU-SUM.
- 018600 05 COND-PLU OCCURS 5 TIMES.
- 018700 07 ACRES-COND-PLU-SUM PIC 9(07)V99.
- 018800 07 AUMS-PRES-COND-PLU-SUM PIC 9(07)V99.
- 018900 07 AUMS-POTN-COND-PLU-SUM PIC 9(07)V99.
- 019000 03 COND-INV-SUM.
- 019100 05 COND-INV OCCURS 5 TIMES.
- 019200 07 ACRES-COND-INV-SUM PIC 9(07)V99.
- 019300 07 AUMS-PRES-COND-INV-SUM PIC 9(07)V99.
- 019400 07 AUMS-POTN-COND-INV-SUM PIC 9(07)V99.
- 019500 01 HDR-1.
- 019600 03 FILLER PIC X(07)
- 019700 VALUE " DATE: ".
- 019800 03 HDR-MO PIC X(04).
- 019900 03 FILLER PIC X(01)
- 020000 VALUE SPACE.
- 020100 03 HDR-DA PIC Z9.
- 020200 03 FILLER PIC X(04)
- 020300 VALUE ", 19".
- 020400 03 HDR-YR PIC 9(02).
- 020500 03 FILLER PIC X(02)
- 020600 VALUE SPACES.
- 020700 03 HDR-HR PIC 9(02).
- 020800 03 FILLER PIC X(01)
- 020900 VALUE ":".
- 021000 03 HDR-MIN PIC 9(02).
- 021100 03 FILLER PIC X(22)
- 021200 VALUE SPACES.
- 021300 03 FILLER PIC X(23) VALUE "U.S.D.I. BUREAU OF LAND".
- 021400 03 FILLER PIC X(11) VALUE " MANAGEMENT".
- 021500 03 FILLER PIC X(22)
- 021600 VALUE SPACES.
- 021700 03 FILLER PIC X(15) VALUE "PCN: P01B ".
- 021800 03 FILLER PIC X(6) VALUE " PAGE ".
- 021900 03 HDR-PG PIC ZZ,ZZ9.
- 022000 01 HDR-2.
- 022100 03 FILLER PIC X(8)
- 022200 VALUE "STATE: ".
- 022300 03 HDR-ST PIC X(02).
- 022400 03 FILLER PIC X(04)
- 022500 VALUE SPACES.
- 022600 03 HDR-ST-NAM PIC X(10).
- 022700 03 FILLER PIC X(30)
- 022800 VALUE SPACES.
- 022900 03 FILLER PIC X(25)
- 023000 VALUE "ECOLOGICAL SITE INVENTORY".
- 023100 03 FILLER PIC X(38)
- 023200 VALUE SPACES.
- 023300 03 FILLER PIC X(06)
- 023400 VALUE SPACE.
- 023500 03 FILLER PIC X(9)
- 023600 VALUE SPACE.
- 023700 01 HDR-3.
- 023800 03 FILLER PIC X(08)
- 023900 VALUE " DI: ".
- 024000 03 HDR-DIST PIC X(02).
- 024100 03 FILLER PIC X(04)
- 024200 VALUE SPACES.
- 024300 03 HDR-DIST-NAM PIC X(12).
- 024400 03 FILLER PIC X(106)
- 024500 VALUE SPACES.
- 024600 01 HDR-4.
- 024700 03 FILLER PIC X(08)
- 024800 VALUE " RA: ".
- 024900 03 HDR-RA PIC X(02).
- 025000 03 FILLER PIC X(04)
- 025100 VALUE SPACES.
- 025200 03 HDR-RA-NAM PIC X(18).
- 025300 03 FILLER PIC X(09)
- 025400 VALUE SPACES.
- 025500 03 FILLER PIC X(25)
- 025600 VALUE "ECOLOGICAL CONDITION CLAS".
- 025700 03 FILLER PIC X(25)
- 025800 VALUE "S/ESTIMATED STOCKING RATE".
- 025900 03 HDR-4-REMARK PIC X(37)
- 026000 VALUE SPACE.
- 026100 03 FILLER PIC X(10)
- 026200 VALUE SPACES.
- 026300 01 HDR-5.
- 026400 03 FILLER PIC X(08)
- 026500 VALUE " PLU: ".
- 026600 03 HDR-PLU PIC X(02).
- 026700 03 FILLER PIC X(04)
- 026800 VALUE SPACES.
- 026900 03 HDR-PLU-NAM PIC X(18).
- 027000 03 FILLER PIC X(100)
- 027100 VALUE SPACES.
- 027200 01 HDR-6 PIC X(132).
- 027300 01 HDR-6A.
- 027400 03 FILLER PIC X(08)
- 027500 VALUE " INV: ".
- 027600 03 HDR-INV-A PIC X(04).
- 027700 03 FILLER PIC X(02)
- 027800 VALUE SPACES.
- 027900 03 HDR-INV-NAM-A PIC X(18).
- 028000 03 FILLER PIC X(20)
- 028100 VALUE SPACES.
- 028200 03 FILLER PIC X(10)
- 028300 VALUE "ALLOTMENT ".
- 028400 03 HDR-ALOT PIC XXXX.
- 028500 03 FILLER PIC X(11)
- 028600 VALUE " PASTURE ".
- 028700 03 HDR-PAST PIC XX.
- 028800 03 FILLER PIC X(54)
- 028900 VALUE SPACES.
- 029000 01 HDR-6B.
- 029100 03 FILLER PIC X(08)
- 029200 VALUE " INV: ".
- 029300 03 HDR-INV-B PIC X(04).
- 029400 03 FILLER PIC X(02)
- 029500 VALUE SPACES.
- 029600 03 HDR-INV-NAM-B PIC X(18).
- 029700 03 FILLER PIC X(100)
- 029800 VALUE SPACES.
- 029900 01 HDR-7.
- 030000 03 FILLER PIC X(33)
- 030100 VALUE " RANGE SITE STRATUM ESTIMAT".
- 030200 03 FILLER PIC X(33)
- 030300 VALUE "ED ACRES OWNER JURIS ".
- 030400 03 FILLER PIC X(33)
- 030500 VALUE " ADMIN LAND ESTIMATE".
- 030600 03 FILLER PIC X(33)
- 030700 VALUE "D AUMS ".
- 030800 01 HDR-8.
- 030900 03 FILLER PIC X(33)
- 031000 VALUE " CONDITI".
- 031100 03 FILLER PIC X(33)
- 031200 VALUE "ON PCT CD ".
- 031300 03 FILLER PIC X(33)
- 031400 VALUE " TYPE PRESENT ".
- 031500 03 FILLER PIC X(33)
- 031600 VALUE " POTENTIAL ".
- 031700 01 HDR-9.
- 031800 03 RMK-H9 PIC X(12)
- 031900 VALUE "ALLOT/PAST ".
- 032000 03 FILLER PIC X(21)
- 032100 VALUE "RANGE SITE ACRES".
- 032200 03 FILLER PIC X(33)
- 032300 VALUE " ESTIMATED AUMS ".
- 032400 03 FILLER PIC X(33)
- 032500 VALUE SPACE.
- 032600 03 FILLER PIC X(33)
- 032700 VALUE SPACE.
- 032800 01 HDR-10.
- 032900 03 FILLER PIC X(33)
- 033000 VALUE SPACE.
- 033100 03 FILLER PIC X(33)
- 033200 VALUE " PRESENT POTENTIAL ".
- 033300 03 FILLER PIC X(33)
- 033400 VALUE SPACE.
- 033500 03 FILLER PIC X(33)
- 033600 VALUE SPACE.
- 033700 01 HDR-11.
- 033800 03 FILLER PIC X(33)
- 033900 VALUE " OWNER ACRES ESTIM".
- 034000 03 FILLER PIC X(33)
- 034100 VALUE "ATED ESTIMATED AUMS ".
- 034200 03 FILLER PIC X(33)
- 034300 VALUE SPACE.
- 034400 03 FILLER PIC X(33)
- 034500 VALUE SPACE.
- 034600 01 HDR-12.
- 034700 03 FILLER PIC X(33)
- 034800 VALUE " CONDI".
- 034900 03 FILLER PIC X(33)
- 035000 VALUE "TION PRESENT POTENTIAL ".
- 035100 03 FILLER PIC X(33)
- 035200 VALUE SPACE.
- 035300 03 FILLER PIC X(33)
- 035400 VALUE SPACE.
- 035500 01 HDR-13.
- 035600 03 FILLER PIC X(33)
- 035700 VALUE " ACRES PERCEN".
- 035800 03 FILLER PIC X(33)
- 035900 VALUE "T ESTIMATED ESTIMATED AUM".
- 036000 03 FILLER PIC X(33)
- 036100 VALUE "S ".
- 036200 03